Tcl Source Code

2013-04-25  Jan Nijtmans  <[email protected]>

	* win/tclWinDde.c:		Update dde to version 1.3.3.
	* library/dde/pkgIndex.tcl:
	* win/tclWinReg.c:		Update registry to version 1.2.2.
	* library/reg/pkgIndex.tcl:

2013-04-18  Jan Nijtmans  <[email protected]>

	* generic/tclDecls.h: Implement Tcl_Pkg* functions as
	(faster/stack-saving) macros around Tcl_Pkg*Ex functions.
	The same for many Tcl_*Var* functions around their
	Tcl_*Var*2 equivalent and Tcl_GetIndexFromObj around
	Tcl_GetIndexFromObjStruct.

if {![package vsatisfies [package provide Tcl] 8]} return
if {[info sharedlibextension] != ".dll"} return
if {[info exists ::tcl_platform(debug)]} {
    package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde]
} else {
    package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde]
}

if {![package vsatisfies [package provide Tcl] 8]} return
if {[info sharedlibextension] != ".dll"} return
if {[info exists ::tcl_platform(debug)]} {
    package ifneeded registry 1.2.2 \
            [list load [file join $dir tclreg12g.dll] registry]
} else {
    package ifneeded registry 1.2.2 \
            [list load [file join $dir tclreg12.dll] registry]
}

# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {

    
    set f [open |[list [interpreter] $::scriptName] r]
    fconfigure $f -buffering line -blocking 1
    gets $f
    return $f
}

# -------------------------------------------------------------------------

test winDde-1.1 {Settings the server's topic name} {pcOnly} {
    list [dde servername foobar] [dde servername] [dde servername self]
}  {foobar foobar self}

test winDde-2.1 {Checking for other services} {pcOnly} {
    expr [llength [dde services {} {}]] >= 0
} 1

test winDde-2.2 {Checking for existence, with service and topic specified} \
	{pcOnly} {
    llength [dde services TclEval self]
} 1

test winDde-2.3 {Checking for existence, with only the service specified} \
	{pcOnly} {
    expr [llength [dde services TclEval {}]] >= 1
} 1

# -------------------------------------------------------------------------

test winDde-3.1 {DDE execute locally} {pcOnly} {
    set a ""
    dde execute TclEval self {set a "foo"}
    set a
} foo

test winDde-3.5 {DDE request locally} {pcOnly} {
    set a ""
    dde execute TclEval self {set a "foo"}
    dde request -binary TclEval self a
} "foo\x00"

# -------------------------------------------------------------------------

test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {

    set a ""
    set name child-4.1
    set child [createChildProcess $name]
    dde execute TclEval $name {set a "foo"}
    dde execute TclEval $name {set done 1}
    update
    set a


} ""
test winDde-4.2 {DDE execute async remotely} {stdio pcOnly} {

    set a ""
    set name child-4.2
    set child [createChildProcess $name]
    dde execute -async TclEval $name {set a "foo"}
    update
    dde execute TclEval $name {set done 1}
    update
    set a


} ""
test winDde-4.3 {DDE request remotely} {stdio pcOnly} {

    set a ""
    set name chile-4.3
    set child [createChildProcess $name]
    dde execute TclEval $name {set a "foo"}
    set a [dde request TclEval $name a]
    dde execute TclEval $name {set done 1}
    update
    set a

} foo

test winDde-4.4 {DDE eval remotely} {stdio pcOnly} {

    set a ""
    set name child-4.4
    set child [createChildProcess $name]
    set a [dde eval $name set a "foo"]
    dde execute TclEval $name {set done 1}
    update
    set a
} foo

# -------------------------------------------------------------------------

test winDde-5.1 {check for bad arguments} {pcOnly} {
    catch {dde execute "" "" "" ""} result
    set result
} {wrong # args: should be "dde execute ?-async? serviceName topicName value"}

test winDde-5.2 {check for bad arguments} {pcOnly} {
    catch {dde execute "" "" ""} result
    set result
} {cannot execute null data}

test winDde-5.3 {check for bad arguments} {pcOnly} {
    catch {dde execute -foo "" "" ""} result
    set result
} {wrong # args: should be "dde execute ?-async? serviceName topicName value"}

test winDde-5.4 {DDE eval bad arguments} {pcOnly} {
    list [catch {dde eval "" "foo"} msg] $msg
} {1 {invalid service name ""}}

# -------------------------------------------------------------------------

#cleanup
#catch {interp delete $slave};           # ensure we clean up the slave.
file delete -force $::scriptName
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

    Title German=Willkommen
    Title Portuguese=Bem-vindo 
    Title Spanish=Bienvenido
    Title Italian=Benvenuto
    Title Danish=Velkommen
    Title Dutch=Welkom
    Title Norwegian=Velkommen
    Title Swedish=V�lkommen
    Width=273
    Height=250
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=166 214 208 228
      Variable=DIRECTION

item: Custom Dialog Set
  Name=Welcome
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Welcome!
      Text French=Bienvenue !
      Text German=Willkommen!
      Text Spanish=�Bienvenido!
      Text Italian=Benvenuti!
    end
    item: Push Button
      Rectangle=150 187 195 202
      Variable=DIRECTION
      Value=N
      Create Flags=01010000000000010000000000000001
      Text=&Next >
      Text French=&Suite >
      Text German=&Weiter >
      Text Spanish=&Siguiente >
      Text Italian=&Avanti >
    end
    item: Push Button
      Rectangle=105 187 150 202
      Variable=DISABLED
      Value=!
      Create Flags=01010000000000010000000000000000
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Action=3
      Create Flags=01010000000000010000000000000000
      Text=&Cancel

      Text=This installation program will install %APPTITLE%.
      Text=
      Text=Press the Next button to start the installation. You can press the Exit Setup button now if you do not want to install %APPTITLE% at this time. 
      Text=
      Text=It is strongly recommended that you exit all Windows programs before running this installation program.
      Text French=Ce programme d'installation va installer %APPTITLE%.
      Text French=
      Text French=Cliquez sur le bouton Suite pour d�marrer l'installation. Vous pouvez cliquer sur le bouton Quitter l'installation si vous ne voulez pas installer %APPTITLE% tout de suite.
      Text German=Mit diesem Installationsprogramm wird %APPTITLE% installiert.
      Text German=
      Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Abbrechen", um die Installation von %APPTITLE% abzubrechen.
      Text Spanish=Este programa de instalaci�n instalar� %APPTITLE%.
      Text Spanish=
      Text Spanish=Presione el bot�n Siguiente para iniciar la instalaci�n. Puede presionar el bot�n Salir de instalaci�n si no desea instalar %APPTITLE% en este momento.
      Text Italian=Questo programma installer� %APPTITLE%.
      Text Italian=
      Text Italian=Per avvviare l'installazione premere il pulsante Avanti. Se non si desidera installare %APPTITLE% ora, premere il pulsante Esci dall'installazione.
    end
    item: Static
      Rectangle=8 180 256 181
      Action=3
      Create Flags=01010000000000000000000000000111
    end
  end
end
item: Custom Dialog Set
  Name=Select Destination Directory
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=150 187 195 202

      Rectangle=105 187 150 202
      Variable=DIRECTION
      Value=B
      Create Flags=01010000000000010000000000000000
      Flags=0000000000000001
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Action=3
      Create Flags=01010000000000010000000000000000
      Text=&Cancel

    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Select Destination Directory
      Text French=S�lectionner le r�pertoire de destination
      Text German=Zielverzeichnis w�hlen
      Text Spanish=Seleccione el directorio de destino
      Text Italian=Selezionare Directory di destinazione
    end
    item: Static
      Rectangle=86 39 256 114
      Create Flags=01010000000000000000000000000000
      Text=Please select the directory where the %APPTITLE% files are to be installed.
      Text=
      Text=To install in the default directory below, click Next.
      Text=
      Text=To install in a different directory, click Browse and select another directory.
      Text French=Veuillez s�lectionner le r�pertoire dans lequel les fichiers %APPTITLE% doivent �tre install�s.
      Text German=Geben Sie an, in welchem Verzeichnis die %APPTITLE%-Dateien installiert werden sollen.
      Text Spanish=Por favor seleccione el directorio donde desee instalar los archivos de %APPTITLE%.
      Text Italian=Selezionare la directory dove verranno installati i file %APPTITLE%.
    end
    item: Static
      Rectangle=86 130 256 157
      Action=1

      Text German=%MAINDIR%
      Text Spanish=%MAINDIR%
      Text Italian=%MAINDIR%
    end
  end
  item: Dialog
    Title=Select Destination Directory
    Title French=S�lectionner le r�pertoire de destination
    Title German=Zielverzeichnis w�hlen
    Title Spanish=Seleccione el directorio de destino
    Title Italian=Selezionare Directory di destinazione
    Width=221
    Height=173
    Font Name=Helv
    Font Size=8
    item: Listbox

remarked item: Custom Dialog Set
  Name=Select Installation Type
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=150 187 195 202

    item: Push Button
      Rectangle=105 187 150 202
      Variable=DIRECTION
      Value=B
      Create Flags=01010000000000010000000000000000
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Action=3
      Create Flags=01010000000000010000000000000000
      Text=&Cancel

    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Select Installation Type
      Text French=S�lectionner les composants
      Text German=Komponenten ausw�hlen
      Text Spanish=Seleccione componentes
      Text Italian=Selezionare i componenti
    end
    item: Static
      Rectangle=194 162 242 172
      Variable=COMPONENTS
      Value=MAINDIR

      Create Flags=01010000000000000000000000000111
    end
    item: Static
      Rectangle=86 42 256 61
      Create Flags=01010000000000000000000000000000
      Text=Choose which type of installation to perform by selecting one of the buttons below.
      Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.
      Text German=W�hlen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden K�stchen klicken.
      Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.
      Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.
    end
    item: Radio Button
      Rectangle=86 74 256 128
      Variable=TYPE
      Create Flags=01010000000000010000000000001001

item: Custom Dialog Set
  Name=Select Components
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=150 187 195 202

    item: Push Button
      Rectangle=105 187 150 202
      Variable=DIRECTION
      Value=B
      Create Flags=01010000000000010000000000000000
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Action=3
      Create Flags=01010000000000010000000000000000
      Text=&Cancel

    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Select Components
      Text French=S�lectionner les composants
      Text German=Komponenten ausw�hlen
      Text Spanish=Seleccione componentes
      Text Italian=Selezionare i componenti
    end
    item: Checkbox
      Rectangle=86 75 256 129
      Variable=COMPONENTS
      Create Flags=01010000000000010000000000000011

      Create Flags=01010000000000000000000000000111
    end
    item: Static
      Rectangle=86 42 256 61
      Create Flags=01010000000000000000000000000000
      Text=Choose which components to install by checking the boxes below.
      Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.
      Text German=W�hlen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden K�stchen klicken.
      Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.
      Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.
    end
  end
end
item: Custom Dialog Set
  Name=Select Program Manager Group
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=150 187 195 202

      Rectangle=105 187 150 202
      Variable=DIRECTION
      Value=B
      Create Flags=01010000000000010000000000000000
      Flags=0000000000000001
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Action=3
      Create Flags=01010000000000010000000000000000
      Text=&Cancel

    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Select ProgMan Group
      Text French=S�lectionner le groupe du Gestionnaire de programme 
      Text German=Bestimmung der Programm-Managergruppe
      Text Spanish=Seleccione grupo del Administrador de programas
      Text Italian=Selezionare il gruppo ProgMan 
    end
    item: Static
      Rectangle=86 44 256 68
      Create Flags=01010000000000000000000000000000
      Text=Enter the name of the Program Manager group to add the %APPTITLE% icons to:
      Text French=Entrez le nom du groupe du Gestionnaire de programme dans lequel vous souhaitez ajouter les ic�nes de %APPTITLE% :
      Text German=Geben Sie den Namen der Programmgruppe ein, der das Symbol %APPTITLE% hinzugef�gt werden soll:
      Text Spanish=Escriba el nombre del grupo del Administrador de programas en el que desea agregar los iconos de %APPTITLE%:
      Text Italian=Inserire il nome del gruppo Program Manager per aggiungere le icone %APPTITLE% a:
    end
    item: Combobox
      Rectangle=86 69 256 175
      Variable=GROUP
      Create Flags=01010000000000010000001000000001

item: Custom Dialog Set
  Name=Start Installation
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=150 187 195 202

    item: Push Button
      Rectangle=105 187 150 202
      Variable=DIRECTION
      Value=B
      Create Flags=01010000000000010000000000000000
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Action=3
      Create Flags=01010000000000010000000000000000
      Text=&Cancel

    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Ready to Install!
      Text French=Pr�t � installer !
      Text German=Installationsbereit!
      Text Spanish=�Preparado para la instalaci�n!
      Text Italian=Pronto per l'installazione!
    end
    item: Static
      Rectangle=86 42 256 102
      Create Flags=01010000000000000000000000000000
      Text=You are now ready to install %APPTITLE%.
      Text=
      Text=Press the Next button to begin the installation or the Back button to reenter the installation information.
      Text French=Vous �tes maintenant pr�t � installer les fichiers %APPTITLE%.
      Text French=
      Text French=Cliquez sur le bouton Suite pour commencer l'installation ou sur le bouton Retour pour entrer les informations d'installation � nouveau.
      Text German=Sie k�nnen %APPTITLE% nun installieren.
      Text German=
      Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Zur�ck", um die Installationsinformationen neu einzugeben.
      Text Spanish=Ya est� listo para instalar %APPTITLE%.
      Text Spanish=
      Text Spanish=Presione el bot�n Siguiente para comenzar la instalaci�n o presione Atr�s para volver a ingresar la informaci�n para la instalaci�n.
      Text Italian=Ora � possibile installare %APPTITLE%.
      Text Italian=
      Text Italian=Premere il pulsante Avanti per avviare l'installazione o il pulsante Indietro per reinserire le informazioni di installazione.
    end
  end
end
item: If/While Statement
  Variable=DISPLAY

item: Install File
  Source=${__TCLBASEDIR__}\library\http1.0\http.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\http1.0\http.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\reg1.2\pkgIndex.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\win\release\tclreg12.dll
  Destination=%MAINDIR%\lib\tcl%VER%\reg1.2\tclreg10.dll
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\library\dde\pkgIndex.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\dde1.3\pkgIndex.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\win\release\tcldde13.dll
  Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde13.dll
  Flags=0000000000000010
end
item: Install File
  Source=C:\WINNT\SYSTEM32\Msvcrt.dll
  Destination=%MAINDIR%\bin\msvcrt.dll
  Flags=0010001000000011
end

item: Custom Dialog Set
  Name=Finished
  Display Variable=DISPLAY
  item: Dialog
    Title=%APPTITLE% Installation
    Title French=Installation de %APPTITLE%
    Title German=Installation von %APPTITLE%
    Title Spanish=Instalaci�n de %APPTITLE%
    Title Italian=Installazione di %APPTITLE%
    Width=271
    Height=224
    Font Name=Helv
    Font Size=8
    item: Push Button
      Rectangle=150 187 195 202

    item: Push Button
      Rectangle=105 187 150 202
      Variable=DISABLED
      Value=!
      Create Flags=01010000000000010000000000000000
      Text=< &Back
      Text French=< &Retour
      Text German=< &Zur�ck
      Text Spanish=< &Atr�s
      Text Italian=< &Indietro
    end
    item: Push Button
      Rectangle=211 187 256 202
      Variable=DISABLED
      Value=!
      Action=3

    item: Static
      Rectangle=86 8 258 42
      Create Flags=01010000000000000000000000000000
      Flags=0000000000000001
      Name=Times New Roman
      Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
      Text=Installation Completed!
      Text French=Installation termin�e !
      Text German=Die Installation ist abgeschlossen!
      Text Spanish=�Instalaci�n terminada!
      Text Italian=Installazione completata!
    end
    item: Static
      Rectangle=86 42 256 153
      Create Flags=01010000000000000000000000000000
      Text=%APPTITLE% has been successfully installed.
      Text=
      Text=Click the Finish button to exit this installation.
      Text=
      Text=You can learn more about Tcl/Tk %VER%, including release notes, updates, tutorials, and more at %URL%.  Check the box below to start your web browser and go there now.
      Text=
      Text=The installer may ask you to reboot your computer, this is to update your PATH and is not necessary to do immediately.
      Text French=%APPTITLE% est maintenant install�.
      Text French=
      Text French=Cliquez sur le bouton Fin pour quitter l'installation.
      Text German=%APPTITLE% wurde erfolgreich installiert.
      Text German=
      Text German=Klicken Sie auf "Weiter", um die Installation zu beenden.
      Text Spanish=%APPTITLE% se ha instalado con �xito.
      Text Spanish=
      Text Spanish=Presione el bot�n Terminar para salir de esta instalaci�n.
      Text Italian=L'installazione %APPTITLE% � stata portata a termine con successo.
      Text Italian=
      Text Italian=Premere il pulsante Fine per uscire dall'installazione.
    end
    item: Checkbox
      Rectangle=88 143 245 157
      Variable=TO_SCRIPTICS
      Enabled Color=00000000000000001111111111111111

	@echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/"
	@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
	@if test "$(STUB_LIB_FILE)" != "" ; then \
	    echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
	    @INSTALL_STUB_LIB@ ; \
	fi
	@if test "x$(DLL_INSTALL_DIR)" = "x$(BIN_INSTALL_DIR)"; then\
	    for i in dde1.3 reg1.2; do \
		if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \
	 	   echo "Making directory $(LIB_INSTALL_DIR)/$$i";\
	 	   mkdir -p $(LIB_INSTALL_DIR)/$$i;\
	 	   chmod 755 $(LIB_INSTALL_DIR)/$$i;\
	 	   else true;\
		fi;\
	    done;\
	    echo "Installing tcldde13.dll";\
		$(INSTALL_DATA) "$(TOP_DIR)/library/dde/pkgIndex.tcl" "$(LIB_INSTALL_DIR)/dde1.3";\
	    $(INSTALL_LIBRARY) "$(TOP_DIR)/win/tcldde13.dll" "$(LIB_INSTALL_DIR)/dde1.3";\
	    chmod 555 "$(LIB_INSTALL_DIR)/dde1.3/tcldde13.dll";\
	    echo "Installing tclreg12.dll";\
		$(INSTALL_DATA) "$(TOP_DIR)/library/reg/pkgIndex.tcl" "$(LIB_INSTALL_DIR)/reg1.2";\
	    $(INSTALL_LIBRARY) "$(TOP_DIR)/win/tclreg12.dll" "$(LIB_INSTALL_DIR)/reg1.2";\
	    chmod 555 "$(LIB_INSTALL_DIR)/reg1.2/tclreg12.dll";\
	fi
	@EXTRA_INSTALL_BINARIES@

install-libraries: libraries
	@for i in "$(INCLUDE_INSTALL_DIR)" "$(SCRIPT_INSTALL_DIR)"; \
	    do \
	    if [ ! -d $$i ] ; then \

echo "$ac_t""$ac_cv_cygwin" 1>&6
	    if test "$ac_cv_cygwin" = "no"; then
		{ echo "configure: error: ${CC} is not a cygwin compiler." 1>&2; exit 1; }
	    fi
	    if test "x${TCL_THREADS}" = "x0"; then
		{ echo "configure: error: CYGWIN compile is only supported with --enable-threads" 1>&2; exit 1; }
	    fi
	    if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde13.dll" -a ! -f "../win/tk84.dll"; then
		{ echo "configure: error: Please configure and make the ../win directory first." 1>&2; exit 1; }
	    fi
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD='${CC} -G'
	    SHLIB_LD_LIBS=""

	    )
	    if test "$ac_cv_cygwin" = "no"; then
		AC_MSG_ERROR([${CC} is not a cygwin compiler.])
	    fi
	    if test "x${TCL_THREADS}" = "x0"; then
		AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads])
	    fi
	    if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde13.dll" -a ! -f "../win/tk84.dll"; then
		AC_MSG_ERROR([Please configure and make the ../win directory first.])
	    fi
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD='${CC} -G'
	    SHLIB_LD_LIBS=""

TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".19"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION

TCL_REG_VERSION=1.2
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=2
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then

TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".19"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.3
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=3
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION

TCL_REG_VERSION=1.2
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=2
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then

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

NAMEPREFIX	= tcl
STUBPREFIX	= $(NAMEPREFIX)stub
DOTVERSION	= 8.4
VERSION		= 84

DDEVERSION = 13
DDEDOTVERSION = 1.3

REGVERSION = 12
REGDOTVERSION = 1.2

BINROOT		= ..
!IF "$(NODEBUG)" == "1"
TMPDIRNAME	= Release
DBGX		=
!ELSE
TMPDIRNAME	= Debug

PROJECT	= tcl
!include "rules.vc"

STUBPREFIX = $(PROJECT)stub
DOTVERSION = 8.4
VERSION = $(DOTVERSION:.=)

DDEDOTVERSION = 1.3
DDEVERSION = $(DDEDOTVERSION:.=)

REGDOTVERSION = 1.2
REGVERSION = $(REGDOTVERSION:.=)

BINROOT		= .
ROOT		= ..

TCLIMPLIB	= $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
TCLLIBNAME	= $(PROJECT)$(VERSION)$(SUFX).$(EXT)

TCL_VERSION	= $(TCL_DOTVERSION:.=)

!if $(TCLINSTALL)
TCLSH		= "$(_INSTALLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
TCLSTUBLIB	= "$(_INSTALLDIR)\lib\tclstub$(TCL_VERSION).lib"
TCLIMPLIB	= "$(_INSTALLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY	= $(_INSTALLDIR)\lib
TCLREGLIB	= "$(_INSTALLDIR)\lib\tclreg12$(SUFX:t=).lib"
TCLDDELIB	= "$(_INSTALLDIR)\lib\tcldde13$(SUFX:t=).lib"
COFFBASE	= \must\have\tcl\sources\to\build\this\target
TCLTOOLSDIR	= \must\have\tcl\sources\to\build\this\target
!else
TCLSH		= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe"
TCLSTUBLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
TCLIMPLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY	= $(_TCLDIR)\library
TCLREGLIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib"
TCLDDELIB	= "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib"
COFFBASE	= "$(_TCLDIR)\win\coffbase.txt"
TCLTOOLSDIR	= $(_TCLDIR)\tools
!endif

!endif

/*
 * tclWinDde.c --
 *
 *	This file provides functions that implement the "send" command,
 *	allowing commands to be passed from interpreter to interpreter.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclPort.h"
#include <dde.h>
#include <ddeml.h>

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init
 * declaration is in the source file itself, which is only accessed when we

 */

typedef struct RegisteredInterp {
    struct RegisteredInterp *nextPtr;
				/* The next interp this application knows
				 * about. */
    char *name;			/* Interpreter's name (malloc-ed). */
    Tcl_Obj *handlerPtr;	/* The server handler command */
    Tcl_Interp *interp;		/* The interpreter attached to this name. */
} RegisteredInterp;

/*
 * Used to keep track of conversations.
 */

typedef struct Conversation {
    struct Conversation *nextPtr;
				/* The next conversation in the list. */
    RegisteredInterp *riPtr;	/* The info we know about the conversation. */
    HCONV hConv;		/* The DDE handle for this conversation. */
    Tcl_Obj *returnPackagePtr;	/* The result package for this conversation. */
} Conversation;

typedef struct DdeEnumServices {
    Tcl_Interp *interp;
    int result;
    ATOM service;
    ATOM topic;
    HWND hwnd;
} DdeEnumServices;

typedef struct ThreadSpecificData {
    Conversation *currentConversations;
				/* A list of conversations currently being
				 * processed. */
    RegisteredInterp *interpListPtr;
				/* List of all interpreters registered in the

 */

static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance;	/* The application instance handle given to us
				 * by DdeInitialize. */
static int ddeIsServer = 0;


#define TCL_DDE_PACKAGE_NAME	"dde"
#define TCL_DDE_SERVICE_NAME	"TclEval"
#define TCL_DDE_EXECUTE_RESULT	"$TCLEVAL$EXECUTE$RESULT"

#define DDE_FLAG_ASYNC 1
#define DDE_FLAG_BINARY 2
#define DDE_FLAG_FORCE 4

TCL_DECLARE_MUTEX(ddeMutex)

/*
 * Forward declarations for functions defined later in this file.
 */

static LRESULT CALLBACK	DdeClientWindowProc(HWND hwnd, UINT uMsg,
			    WPARAM wParam, LPARAM lParam);
static int		DdeCreateClient(struct DdeEnumServices *es);
static BOOL CALLBACK	DdeEnumWindowsCallback(HWND hwndTarget,
			    LPARAM lParam);
static void		DdeExitProc(ClientData clientData);
static int		DdeGetServicesList(Tcl_Interp *interp,
			    const char *serviceName, const char *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
			    HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
			    DWORD dwData1, DWORD dwData2);
static LRESULT		DdeServicesOnAck(HWND hwnd, WPARAM wParam,
			    LPARAM lParam);
static void		DeleteProc(ClientData clientData);
static Tcl_Obj *	ExecuteRemoteObject(RegisteredInterp *riPtr,
			    Tcl_Obj *ddeObjectPtr);
static int		MakeDdeConnection(Tcl_Interp *interp,
			    const char *name, HCONV *ddeConvPtr);
static void		SetDdeError(Tcl_Interp *interp);
static int		DdeObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

EXTERN int		Dde_Init(Tcl_Interp *interp);
EXTERN int		Dde_SafeInit(Tcl_Interp *interp);

/*
 *----------------------------------------------------------------------
 *
 * Dde_Init --
 *
 *	This function initializes the dde command.

{
    if (!Tcl_InitStubs(interp, "8.1", 0)) {
	return TCL_ERROR;
    }

    Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
    Tcl_CreateExitHandler(DdeExitProc, NULL);
    return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3");
}

/*
 *----------------------------------------------------------------------
 *
 * Dde_SafeInit --
 *
 *	This function initializes the dde command within a safe interp
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Dde_SafeInit(
    Tcl_Interp *interp)
{
    int result = Dde_Init(interp);
    if (result == TCL_OK) {
	Tcl_HideCommand(interp, "dde", "dde");
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Initialize --
 *

    }
    if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
	Tcl_MutexLock(&ddeMutex);
	if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
	    ddeIsServer = 1;
	    Tcl_CreateExitHandler(DdeExitProc, NULL);
	    ddeServiceGlobal = DdeCreateStringHandle(ddeInstance,
		    TCL_DDE_SERVICE_NAME, 0);
	    DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
	} else {
	    ddeIsServer = 0;
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
}

 *
 *----------------------------------------------------------------------
 */

static const char *
DdeSetServerName(
    Tcl_Interp *interp,
    const char *name, /* The name that will be used to refer to the
				 * interpreter in later "send" commands. Must
				 * be globally unique. */

    int flags,		/* DDE_FLAG_FORCE or 0 */
    Tcl_Obj *handlerPtr)	/* Name of the optional proc/command to handle
				 * incoming Dde eval's */
{
    int suffix, offset;
    RegisteredInterp *riPtr, *prevPtr;
    Tcl_DString dString;
    const char *actualName;
    Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
    int n, srvCount = 0, lastSuffix, r = TCL_OK;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * See if the application is already registered; if so, remove its current
     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

	 * The name was NULL, so the caller is asking for the name of the
	 * current interp, but it doesn't have a name.
	 */

	return "";
    }

    /*
     * Get the list of currently registered Tcl interpreters by calling the
     * internal implementation of the 'dde services' command.
     */

    Tcl_DStringInit(&dString);
    actualName = name;

    if (!(flags & DDE_FLAG_FORCE)) {
	r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
	if (r == TCL_OK) {
	    srvListPtr = Tcl_GetObjResult(interp);
	}
	if (r == TCL_OK) {
	    r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
		    &srvPtrPtr);
	}
	if (r != TCL_OK) {
	    OutputDebugString(Tcl_GetStringResult(interp));
	    return NULL;
	}

	/*
	 * Pick a name to use for the application. Use "name" if it's not
	 * already in use. Otherwise add a suffix such as " #2", trying larger
	 * and larger numbers until we eventually find one that is unique.
	 */

	offset = lastSuffix = 0;
	suffix = 1;

	while (suffix != lastSuffix) {
	    lastSuffix = suffix;
	    if (suffix > 1) {
		if (suffix == 2) {
		    Tcl_DStringAppend(&dString, name, -1);
		    Tcl_DStringAppend(&dString, " #", 2);
		    offset = Tcl_DStringLength(&dString);
		    Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE);
		    actualName = Tcl_DStringValue(&dString);
		}
		sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
	    }

	    /*
	     * See if the name is already in use, if so increment suffix.
	     */

	    for (n = 0; n < srvCount; ++n) {
		Tcl_Obj* namePtr;

		Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
		if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) {
		    suffix++;
		    break;
		}
	    }
	}
	Tcl_DStringSetLength(&dString,
		offset + (int)strlen(Tcl_DStringValue(&dString)+offset));
    }

    /*
     * We have found a unique name. Now add it to the registry.
     */

    riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
    riPtr->interp = interp;
    riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
    riPtr->nextPtr = tsdPtr->interpListPtr;
    riPtr->handlerPtr = handlerPtr;
    if (riPtr->handlerPtr != NULL) {
	Tcl_IncrRefCount(riPtr->handlerPtr);
    }
    tsdPtr->interpListPtr = riPtr;
    strcpy(riPtr->name, actualName);

    if (Tcl_IsSafe(interp)) {
	Tcl_ExposeCommand(interp, "dde", "dde");
    }

    Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
	    (ClientData) riPtr, DeleteProc);
    if (Tcl_IsSafe(interp)) {
	Tcl_HideCommand(interp, "dde", "dde");
    }
    Tcl_DStringFree(&dString);

    /*
     * Re-initialize with the new name.
     */

    Initialize();

    return riPtr->name;
}

/*
 *----------------------------------------------------------------------
 *
 * DdeGetRegistrationPtr
 *
 *	Retrieve the registration info for an interpreter.
 *
 * Results:
 *	Returns a pointer to the registration structure or NULL
 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static RegisteredInterp *
DdeGetRegistrationPtr(
    Tcl_Interp *interp)
{
    RegisteredInterp *riPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
	    riPtr = riPtr->nextPtr) {
	if (riPtr->interp == interp) {
	    break;
	}
    }
    return riPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteProc
 *
 *	This function is called when the command "dde" is destroyed.

	if (prevPtr == NULL) {
	    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
	} else {
	    prevPtr->nextPtr = searchPtr->nextPtr;
	}
    }
    ckfree(riPtr->name);
    if (riPtr->handlerPtr) {
	Tcl_DecrRefCount(riPtr->handlerPtr);
    }
    Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteRemoteObject --

static Tcl_Obj *
ExecuteRemoteObject(
    RegisteredInterp *riPtr,	    /* Info about this server. */
    Tcl_Obj *ddeObjectPtr)	    /* The object to execute. */
{
    Tcl_Obj *returnPackagePtr;
    int result = TCL_OK;

    if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) {
	Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
		"a handler procedure must be defined for use in a safe "
		"interp", -1));
	result = TCL_ERROR;
    }

    if (riPtr->handlerPtr != NULL) {
	/*
	 * Add the dde request data to the handler proc list.
	 */

	Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);

	result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr,
		ddeObjectPtr);
	if (result == TCL_OK) {
	    ddeObjectPtr = cmdPtr;
	}
    }

    if (result == TCL_OK) {
	result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
    }

    returnPackagePtr = Tcl_NewListObj(0, NULL);

    Tcl_ListObjAppendElement(NULL, returnPackagePtr,
	    Tcl_NewIntObj(result));
    Tcl_ListObjAppendElement(NULL, returnPackagePtr,
	    Tcl_GetObjResult(riPtr->interp));

    if (result == TCL_ERROR) {
	Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,

		    returnString = (char *)
			    Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len);
		    len = 2 * len + 1;
		}
		ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
			(DWORD) len+1, 0, ddeItem, uFmt, 0);
	    } else {
		if (Tcl_IsSafe(convPtr->riPtr->interp)) {
		    ddeReturn = NULL;
		} else {
		    Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
			    convPtr->riPtr->interp, utilString, NULL,
			    TCL_GLOBAL_ONLY);
		    if (variableObjPtr != NULL) {
			if (uFmt == CF_TEXT) {
			    returnString = Tcl_GetStringFromObj(
				    variableObjPtr, &len);
			} else {
			    returnString = (char *) Tcl_GetUnicodeFromObj(
				    variableObjPtr, &len);
			    len = 2 * len + 1;
			}
			ddeReturn = DdeCreateDataHandle(ddeInstance,
				(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
				uFmt, 0);
		    } else {
			ddeReturn = NULL;
		    }
		}
	    }
	    Tcl_DStringFree(&dString);
	}
	return ddeReturn;

    case XTYP_EXECUTE: {

    Tcl_Interp *interp,		/* Used to report errors. */
    const char *name,		/* The connection to use. */
    HCONV *ddeConvPtr)
{
    HSZ ddeTopic, ddeService;
    HCONV ddeConv;

    ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0);
    ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);

    ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
    DdeFreeStringHandle(ddeInstance, ddeService);
    DdeFreeStringHandle(ddeInstance, ddeTopic);

    if (ddeConv == (HCONV) NULL) {
	if (interp != NULL) {

 *
 * Side effects:
 *	Sets the services list into the interp result.
 *
 *----------------------------------------------------------------------
 */














static int
DdeCreateClient(
    struct DdeEnumServices *es)
{
    WNDCLASSEX wc;
    static const char *szDdeClientClassName = "TclEval client class";
    static const char *szDdeClientWindowName = "TclEval client window";

    memset(&wc, 0, sizeof(wc));
    wc.cbSize = sizeof(wc);
    wc.lpfnWndProc = DdeClientWindowProc;
    wc.lpszClassName = szDdeClientClassName;
    wc.cbWndExtra = sizeof(struct DdeEnumServices *);

    /*
     * Register and create the callback window.
     */

    RegisterClassEx(&wc);
    es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName,

    UINT uMsg,			/* The type of message received */
    WPARAM wParam,
    LPARAM lParam)		/* (Potentially) our local handle */
{
    switch (uMsg) {
    case WM_CREATE: {
	LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
	struct DdeEnumServices *es =
		(struct DdeEnumServices *) lpcs->lpCreateParams;

#ifdef _WIN64
	SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es);
#else
	SetWindowLong(hwnd, GWL_USERDATA, (LONG) es);
#endif
	return (LRESULT) 0L;
    }

    HWND hwnd,
    WPARAM wParam,
    LPARAM lParam)
{
    HWND hwndRemote = (HWND)wParam;
    ATOM service = (ATOM)LOWORD(lParam);
    ATOM topic = (ATOM)HIWORD(lParam);
    struct DdeEnumServices *es;
    char sz[255];

#ifdef _WIN64
    es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
    es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA);
#endif

    if ((es->service == (ATOM)0 || es->service == service)
	    && (es->topic == (ATOM)0 || es->topic == topic)) {
	Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
	Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);

	GlobalGetAtomName(service, sz, 255);
	Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));

	GlobalGetAtomName(topic, sz, 255);
	Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1));


	/*
	 * Adding the hwnd as a third list element provides a unique
	 * identifier in the case of multiple servers with the name
	 * application and topic names.
	 */
	/*
	 * Needs a TIP though:
	 * Tcl_ListObjAppendElement(NULL, matchPtr,
	 *	Tcl_NewLongObj((long)hwndRemote));
	 */

	if (Tcl_IsShared(resultPtr)) {
	    resultPtr = Tcl_DuplicateObj(resultPtr);
	}
	if (Tcl_ListObjAppendElement(es->interp, resultPtr,
		matchPtr) == TCL_OK) {
	    Tcl_SetObjResult(es->interp, resultPtr);
	}
    }

    /*
     * Tell the server we are no longer interested.
     */

    PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
    return 0L;
}

static BOOL CALLBACK
DdeEnumWindowsCallback(
    HWND hwndTarget,
    LPARAM lParam)
{
    DWORD_PTR dwResult = 0;
    struct DdeEnumServices *es = (struct DdeEnumServices *) lParam;

    SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
	    MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
	    &dwResult);
    return TRUE;
}

static int
DdeGetServicesList(
    Tcl_Interp *interp,
    const char *serviceName,
    const char *topicName)
{
    struct DdeEnumServices es;

    es.interp = interp;
    es.result = TCL_OK;
    es.service = (serviceName == NULL)
	    ? (ATOM)0 : GlobalAddAtom(serviceName);
    es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtom(topicName);

    Tcl_Interp *interp,		/* The interp we are sending from */
    int objc,			/* Number of arguments */
    Tcl_Obj *const *objv)	/* The arguments */
{
    static const char *ddeCommands[] = {
	"servername", "execute", "poke", "request", "services", "eval",
	(char *) NULL};
    enum DdeSubcommands {
	DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
	DDE_EVAL
    };
    static const char *ddeSrvOptions[] = {
	"-force", "-handler", "--", NULL
    };
    enum DdeSrvOptions {
	DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST,
    };
    static const char *ddeExecOptions[] = {
	"-async", NULL
    };
    static const char *ddeReqOptions[] = {
	"-binary", NULL
    };

    int index, i, length, argIndex;

    int flags = 0, result = TCL_OK, firstArg = 0;
    HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
    HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
    HCONV hConv = NULL;
    const char *serviceName = NULL, *topicName = NULL, *string;
    DWORD ddeResult;
    Tcl_Obj *objPtr, *handlerPtr = NULL;

    /*
     * Initialize DDE server/client
     */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum DdeSubcommands) index) {
    case DDE_SERVERNAME:
	for (i = 2; i < objc; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions,
		    "option", 0, &argIndex) != TCL_OK) {
		/*
		 * If it is the last argument, it might be a server name
		 * instead of a bad argument.
		 */

		if (i != objc-1) {
		    return TCL_ERROR;
		}
		Tcl_ResetResult(interp);
		break;
	    }
	    if (argIndex == DDE_SERVERNAME_EXACT) {
		flags |= DDE_FLAG_FORCE;
	    } else if (argIndex == DDE_SERVERNAME_HANDLER) {
		if ((objc - i) == 1) {	/* return current handler */
		    RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp);

		    if (riPtr && riPtr->handlerPtr) {
			Tcl_SetObjResult(interp, riPtr->handlerPtr);
		    } else {
			Tcl_ResetResult(interp);
		    }
		    return TCL_OK;
		}
		handlerPtr = objv[++i];
	    } else if (argIndex == DDE_SERVERNAME_LAST) {
		i++;
		break;
	    }
	}

	if ((objc - i) > 1) {
	    Tcl_ResetResult(interp);
	    Tcl_WrongNumArgs(interp, 2, objv,
		    "?-force? ?-handler proc? ?--? ?serverName?");
	    return TCL_ERROR;
	}

	firstArg = (objc == i) ? 1 : i;
	break;
    case DDE_EXECUTE:
	if (objc == 5) {
	    firstArg = 2;
	    break;
	} else if (objc == 6) {

	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0,
		    &argIndex) == TCL_OK) {
		flags |= DDE_FLAG_ASYNC;
		firstArg = 3;
		break;
	    }
	}
	/* otherwise... */
	Tcl_WrongNumArgs(interp, 2, objv,
		"?-async? serviceName topicName value");

	if (objc == 5) {
	    firstArg = 2;
	    break;
	} else if (objc == 6) {
	    int dummy;
	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
		    &dummy) == TCL_OK) {
		flags |= DDE_FLAG_BINARY;
		firstArg = 3;
		break;
	    }
	}

	/*
	 * Otherwise ...

	} else {
	    firstArg = 2;
	    if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option",
		    0, &argIndex) == TCL_OK) {
		if (objc < 5) {
		    goto wrongDdeEvalArgs;
		}
		flags |= DDE_FLAG_ASYNC;
		firstArg++;
	    }
	    break;
	}
    }

    Initialize();

	    topicName = NULL;
	} else {
	    ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName,
		    CP_WINANSI);
	}
    }

    switch ((enum DdeSubcommands) index) {
    case DDE_SERVERNAME:
	serviceName = DdeSetServerName(interp, serviceName, flags,
		handlerPtr);
	if (serviceName != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1));
	} else {
	    Tcl_ResetResult(interp);
	}
	break;

    case DDE_EXECUTE: {
	int dataLength;
	BYTE *dataString = (BYTE *) Tcl_GetStringFromObj(
		objv[firstArg + 2], &dataLength);

	if (dataLength == 0) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("cannot execute null data", -1));
	    result = TCL_ERROR;
	    break;
	}
	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);

	DdeFreeStringHandle(ddeInstance, ddeService);


	DdeFreeStringHandle(ddeInstance, ddeTopic);


	if (hConv == NULL) {
	    SetDdeError(interp);
	    result = TCL_ERROR;
	    break;
	}

	ddeData = DdeCreateDataHandle(ddeInstance, dataString,
		(DWORD) dataLength+1, 0, 0, CF_TEXT, 0);
	if (ddeData != NULL) {
	    if (flags & DDE_FLAG_ASYNC) {
		DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
			CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
		DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
	    } else {
		ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
			hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
		if (ddeReturn == 0) {

	if (length == 0) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("cannot request value of null data", -1));
	    result = TCL_ERROR;
	    goto cleanup;
	}
	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);

	DdeFreeStringHandle(ddeInstance, ddeService);


	DdeFreeStringHandle(ddeInstance, ddeTopic);


	if (hConv == NULL) {
	    SetDdeError(interp);
	    result = TCL_ERROR;
	} else {
	    Tcl_Obj *returnObjPtr;
	    ddeItem = DdeCreateStringHandle(ddeInstance, (void *)itemString,
		    CP_WINANSI);
	    if (ddeItem != NULL) {
		ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
			CF_TEXT, XTYP_REQUEST, 5000, NULL);
		if (ddeData == NULL) {
		    SetDdeError(interp);
		    result = TCL_ERROR;
		} else {
		    DWORD tmp;
		    const char *dataString = (const char *) DdeAccessData(ddeData, &tmp);

		    if (flags & DDE_FLAG_BINARY) {
			returnObjPtr =
				Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp);
		    } else {
			if (tmp && !dataString[tmp-1]) {
			    --tmp;
			}
			returnObjPtr = Tcl_NewStringObj(dataString,
				(int) tmp);
		    }

	    result = TCL_ERROR;
	    goto cleanup;
	}
	dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3],
		&length);

	hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);

	DdeFreeStringHandle(ddeInstance, ddeService);


	DdeFreeStringHandle(ddeInstance, ddeTopic);


	if (hConv == NULL) {
	    SetDdeError(interp);
	    result = TCL_ERROR;
	} else {
	    ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString,
		    CP_WINANSI);

	if (serviceName == NULL) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("invalid service name \"\"", -1));
	    result = TCL_ERROR;
	    goto cleanup;
	}

	objc -= firstArg + 1;
	objv += firstArg + 1;

	/*
	 * See if the target interpreter is local. If so, execute the command
	 * directly without going through the DDE server. Don't exchange
	 * objects between interps. The target interp could compile an object,
	 * producing a bytecode structure that refers to other objects owned
	 * by the target interp. If the target interp is then deleted, the

	     * Don't exchange objects between interps. The target interp would
	     * compile an object, producing a bytecode structure that refers
	     * to other objects owned by the target interp. If the target
	     * interp is then deleted, the bytecode structure would be
	     * referring to deallocated objects.
	     */

	    if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) {
		Tcl_SetResult(riPtr->interp, "permission denied: "
			"a handler procedure must be defined for use in "
			"a safe interp", TCL_STATIC);
		result = TCL_ERROR;
	    }

	    if (result == TCL_OK) {
		if (objc == 1)
		    objPtr = objv[0];

		else {
		    objPtr = Tcl_ConcatObj(objc, objv);
		}
		if (riPtr->handlerPtr != NULL) {
		    /* add the dde request data to the handler proc list */
		    /*
		     *result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1,
		     *	    &(riPtr->handlerPtr));
		     */
		    Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);
		    result = Tcl_ListObjAppendElement(sendInterp, cmdPtr,
			    objPtr);
		    if (result == TCL_OK) {
			objPtr = cmdPtr;
		    }
		}
	    }
	    if (result == TCL_OK) {
		Tcl_IncrRefCount(objPtr);
		result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
		Tcl_DecrRefCount(objPtr);
	    }
	    if (interp != sendInterp) {
		if (result == TCL_ERROR) {
		    /*

	     * This is a non-local request. Send the script to the server and
	     * poll it for a result.
	     */

	    if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
	    invalidServerResponse:
		Tcl_SetObjResult(interp,
			Tcl_NewStringObj("invalid data returned from server",
			-1));
		result = TCL_ERROR;
		goto cleanup;
	    }

	    objPtr = Tcl_ConcatObj(objc, objv);
	    string = Tcl_GetStringFromObj(objPtr, &length);
	    ddeItemData = DdeCreateDataHandle(ddeInstance,
		    (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0);

	    if (flags & DDE_FLAG_ASYNC) {
		ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
			0xFFFFFFFF, hConv, 0,
			CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
		DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
	    } else {
		ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
			0xFFFFFFFF, hConv, 0,

	    }

	    Tcl_DecrRefCount(objPtr);

	    if (ddeData == 0) {
		SetDdeError(interp);
		result = TCL_ERROR;

	    }

	    if (!(flags & DDE_FLAG_ASYNC)) {
		Tcl_Obj *resultPtr;

		/*
		 * The return handle has a two or four element list in it. The
		 * first element is the return code (TCL_OK, TCL_ERROR, etc.).
		 * The second is the result of the script. If the return code
		 * is TCL_ERROR, then the third element is the value of the

/*
 * tclWinReg.c --
 *
 *	This file contains the implementation of the "registry" Tcl built-in
 *	command. This command is built as a dynamically loadable extension in
 *	a separate DLL.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclPort.h"
#ifdef _MSC_VER
#   pragma comment (lib, "advapi32.lib")
#endif
#include <stdlib.h>

/*
 * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
 * Registry_Init declaration is in the source file itself, which is only
 * accessed when we are building a library.
 */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

/*
 * The maximum length of a sub-key name.
 */

#ifndef MAX_KEY_LENGTH
#define MAX_KEY_LENGTH		256
#endif

/*
 * The following macros convert between different endian ints.
 */

#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))

/*
 * The following flag is used in OpenKeys to indicate that the specified key
 * should be created if it doesn't currently exist.
 */

#define REG_CREATE 1

/*
 * The following tables contain the mapping from registry root names to the
 * system predefined keys.
 */

static CONST char *rootKeyNames[] = {
    "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
    "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
    "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
};

static const HKEY rootKeys[] = {
    HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
    HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
};

static CONST char REGISTRY_ASSOC_KEY[] = "registry::command";

/*
 * The following table maps from registry types to strings. Note that the
 * indices for this array are the same as the constants for the known registry
 * types so we don't need a separate table to hold the mapping.

 */

static CONST char *typeNames[] = {
    "none", "sz", "expand_sz", "binary", "dword",
    "dword_big_endian", "link", "multi_sz", "resource_list", NULL
};

static DWORD lastType = REG_RESOURCE_LIST;

/*
 * The following structures allow us to select between the Unicode and ASCII
 * interfaces at run time based on whether Unicode APIs are available. The
 * Unicode APIs are preferable because they will handle characters outside of
 * the current code page.
 */

typedef struct RegWinProcs {
    int useWide;

    LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
    LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
    LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
    LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
    LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *);
    LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *);
    LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
	    HKEY *);



    LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
	    BYTE *, DWORD *);
    LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
	    CONST BYTE*, DWORD);
} RegWinProcs;

static RegWinProcs *regWinProcs;

static RegWinProcs asciiProcs = {
    0,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
	    HKEY *)) RegOpenKeyExA,



    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
	    BYTE *, DWORD *)) RegQueryValueExA,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
	    CONST BYTE*, DWORD)) RegSetValueExA,
};

static RegWinProcs unicodeProcs = {
    1,

    (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
	    DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
	    DWORD *)) RegCreateKeyExW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
    (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
	    DWORD *, BYTE *, DWORD *)) RegEnumValueW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
	    HKEY *)) RegOpenKeyExW,



    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
	    BYTE *, DWORD *)) RegQueryValueExW,
    (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
	    CONST BYTE*, DWORD)) RegSetValueExW,
};


/*
 * Declarations for functions defined in this file.
 */

static void		AppendSystemError(Tcl_Interp *interp, DWORD error);
static int		BroadcastValue(Tcl_Interp *interp, int objc,
			    Tcl_Obj * CONST objv[]);
static DWORD		ConvertDWORD(DWORD type, DWORD value);
static void		DeleteCmd(ClientData clientData);
static int		DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
static int		DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj);
static int		GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *patternObj);
static int		GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj);

static int		RegistryObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj * CONST objv[]);
static int		SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
			    Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
			    Tcl_Obj *typeObj);

EXTERN int		Registry_Init(Tcl_Interp *interp);
EXTERN int		Registry_Unload(Tcl_Interp *interp, int flags);

/*
 *----------------------------------------------------------------------
 *
 * Registry_Init --
 *
 *	This function initializes the registry command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Registry_Init(
    Tcl_Interp *interp)
{
    Tcl_Command cmd;

    if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
	return TCL_ERROR;
    }

    /*
     * Determine if the unicode interfaces are available and select the
     * appropriate registry function table.
     */

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
	regWinProcs = &unicodeProcs;
    } else {
	regWinProcs = &asciiProcs;
    }

    cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
	(ClientData)interp, DeleteCmd);
    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd);
    return Tcl_PkgProvide(interp, "registry", "1.2.2");
}

/*
 *----------------------------------------------------------------------
 *
 * Registry_Unload --
 *
 *	This function removes the registry command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	The registry command is deleted and the dll may be unloaded.
 *
 *----------------------------------------------------------------------
 */

int
Registry_Unload(
    Tcl_Interp *interp,		/* Interpreter for unloading */
    int flags)			/* Flags passed by the unload system */
{
    Tcl_Command cmd;
    Tcl_Obj *objv[3];

    /*
     * Unregister the registry package. There is no Tcl_PkgForget()
     */

    objv[0] = Tcl_NewStringObj("package", -1);
    objv[1] = Tcl_NewStringObj("forget", -1);
    objv[2] = Tcl_NewStringObj("registry", -1);
    Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);

    /*
     * Delete the originally registered command.
     */

    cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
    if (cmd != NULL) {
	Tcl_DeleteCommandFromToken(interp, cmd);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteCmd --
 *
 *	Cleanup the interp command token so that unloading doesn't try to
 *	re-delete the command (which will crash).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The unload command will not attempt to delete this command.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteCmd(
    ClientData clientData)
{
    Tcl_Interp *interp = clientData;
    Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * RegistryObjCmd --
 *

    int objc,			/* Number of arguments. */
    Tcl_Obj * CONST objv[])	/* Argument values. */
{
    int index;
    char *errString = NULL;

    static CONST char *subcommands[] = {
	"broadcast", "delete", "get", "keys", "set", "type", "values", NULL

    };
    enum SubCmdIdx {
	BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    switch (index) {
    case BroadcastIdx:		/* broadcast */
	return BroadcastValue(interp, objc, objv);
	break;
    case DeleteIdx:		/* delete */
	if (objc == 3) {
	    return DeleteKey(interp, objv[2]);
	} else if (objc == 4) {
	    return DeleteValue(interp, objv[2], objv[3]);
	}
	errString = "keyName ?valueName?";
	break;
    case GetIdx:		/* get */
	if (objc == 4) {
	    return GetValue(interp, objv[2], objv[3]);
	}
	errString = "keyName valueName";
	break;
    case KeysIdx:		/* keys */
	if (objc == 3) {
	    return GetKeyNames(interp, objv[2], NULL);
	} else if (objc == 4) {
	    return GetKeyNames(interp, objv[2], objv[3]);
	}
	errString = "keyName ?pattern?";
	break;
    case SetIdx:		/* set */
	if (objc == 3) {
	    HKEY key;

	    /*
	     * Create the key and then close it immediately.
	     */

	    if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) {

		return TCL_ERROR;
	    }
	    RegCloseKey(key);
	    return TCL_OK;
	} else if (objc == 5 || objc == 6) {
	    Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
	    return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
	}
	errString = "keyName ?valueName data ?type??";
	break;
    case TypeIdx:		/* type */
	if (objc == 4) {
	    return GetType(interp, objv[2], objv[3]);
	}
	errString = "keyName valueName";
	break;
    case ValuesIdx:		/* values */
	if (objc == 3) {
	    return GetValueNames(interp, objv[2], NULL);
	} else if (objc == 4) {
	    return GetValueNames(interp, objv[2], objv[3]);
	}
	errString = "keyName ?pattern?";
	break;
    }
    Tcl_WrongNumArgs(interp, 2, objv, errString);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------

    Tcl_Obj *keyNameObj)	/* Name of key to delete. */
{
    char *tail, *buffer, *hostName, *keyName;
    CONST char *nativeTail;
    HKEY rootKey, subkey;
    DWORD result;
    int length;

    Tcl_DString buf;

    /*
     * Find the parent of the key being deleted and open it.
     */

    keyName = Tcl_GetStringFromObj(keyNameObj, &length);
    buffer = ckalloc((unsigned int) length + 1);
    strcpy(buffer, keyName);

    if (ParseKeyName(interp, buffer, &hostName, &rootKey,
	    &keyName) != TCL_OK) {
	ckfree(buffer);
	return TCL_ERROR;
    }


    if (*keyName == '\0') {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad key: cannot delete root keys", -1));
	ckfree(buffer);
	return TCL_ERROR;
    }

    tail = strrchr(keyName, '\\');
    if (tail) {
	*tail++ = '\0';
    } else {
	tail = keyName;
	keyName = NULL;
    }

    result = OpenSubKey(hostName, rootKey, keyName,
	    KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
    if (result != ERROR_SUCCESS) {
	ckfree(buffer);
	if (result == ERROR_FILE_NOT_FOUND) {
	    return TCL_OK;

	}
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"unable to delete key: ", -1));
	AppendSystemError(interp, result);
	return TCL_ERROR;

    }

    /*
     * Now we recursively delete the key and everything below it.
     */

    nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf);
    result = RecursiveDeleteKey(subkey, nativeTail);
    Tcl_DStringFree(&buf);

    if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("unable to delete key: ", -1));
	AppendSystemError(interp, result);
	result = TCL_ERROR;
    } else {
	result = TCL_OK;
    }

    RegCloseKey(subkey);

    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj)	/* Name of value to delete. */
{
    HKEY key;
    char *valueName;
    int length;
    DWORD result;

    Tcl_DString ds;

    /*
     * Attempt to open the key for deletion.
     */

    if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
	    != TCL_OK) {
	return TCL_ERROR;
    }


    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    Tcl_WinUtfToTChar(valueName, length, &ds);
    result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
    Tcl_DStringFree(&ds);
    if (result != ERROR_SUCCESS) {
	Tcl_AppendResult(interp, "unable to delete value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	result = TCL_ERROR;
    } else {
	result = TCL_OK;
    }
    RegCloseKey(key);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * GetKeyNames --
 *
 *	This function enumerates the subkeys of a given key. If the optional
 *	pattern is supplied, then only keys that match the pattern will be
 *	returned.
 *
 * Results:
 *	Returns the list of subkeys in the result object of the interpreter,
 *	or an error message on failure.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetKeyNames(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Key to enumerate. */
    Tcl_Obj *patternObj)	/* Optional match pattern. */
{
    char *pattern;		/* Pattern being matched against subkeys */
    HKEY key;			/* Handle to the key being examined */


    TCHAR buffer[MAX_KEY_LENGTH*2];		/* Buffer to hold the subkey name */
    DWORD bufSize;		/* Size of the buffer */
    DWORD index;		/* Position of the current subkey */
    char *name;			/* Subkey name */
    Tcl_Obj *resultPtr;		/* List of subkeys being accumulated */
    int result = TCL_OK;	/* Return value from this command */
    Tcl_DString ds;		/* Buffer to translate subkey name to UTF-8 */

    if (OpenKey(interp, keyNameObj,
		KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS,
		0, &key) != TCL_OK) {
	return TCL_ERROR;
    }























    /* Enumerate the subkeys */

    resultPtr = Tcl_NewObj();
    for (index = 0;; ++index) {
	bufSize = MAX_KEY_LENGTH;
	result = (*regWinProcs->regEnumKeyExProc)
	    (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL);
	if (result != ERROR_SUCCESS) {
	    if (result == ERROR_NO_MORE_ITEMS) {
		result = TCL_OK;
	    } else {
		Tcl_SetObjResult(interp, Tcl_NewObj());
		Tcl_AppendResult(interp,
			"unable to enumerate subkeys of \"",
			Tcl_GetString(keyNameObj), "\": ", NULL);

		AppendSystemError(interp, result);
		result = TCL_ERROR;
	    }
	    break;
	}
	if (regWinProcs->useWide) {
	    Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds);
	} else {
	    Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds);
	}

    }
    if (result == TCL_OK) {
	Tcl_SetObjResult(interp, resultPtr);
    } else {
	Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */
    }


    RegCloseKey(key);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * GetType --
 *
 *	This function gets the type of a given registry value and places it in
 *	the interpreter result.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetType(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj)	/* Name of value to get. */
{
    HKEY key;

    DWORD result;
    DWORD type;
    Tcl_DString ds;
    char *valueName;
    CONST char *nativeValue;
    int length;

    /*
     * Attempt to open the key for reading.
     */

    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Get the type of the value.
     */



    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
    result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
	    NULL, NULL);
    Tcl_DStringFree(&ds);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {
	Tcl_AppendResult(interp, "unable to get type of value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }

    /*
     * Set the type into the result. Watch out for unknown types. If we don't
     * know about the type, just use the numeric value.
     */

    if (type > lastType) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type));
    } else {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetValue --
 *
 *	This function gets the contents of a registry value and places a list
 *	containing the data and the type in the interpreter result.

 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj)	/* Name of value to get. */
{
    HKEY key;
    char *valueName;
    CONST char *nativeValue;
    DWORD result, length, type;

    Tcl_DString data, buf;
    int nameLen;

    /*
     * Attempt to open the key for reading.
     */

    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) {

	return TCL_ERROR;
    }

    /*
     * Initialize a Dstring to maximum statically allocated size we could get
     * one more byte by avoiding Tcl_DStringSetLength() and just setting
     * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the
     * implementation of Dstrings changes.
     *
     * This allows short values to be read from the registy in one call.
     * Longer values need a second call with an expanded DString.
     */

    Tcl_DStringInit(&data);
    Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
    length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1;



    valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
    nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);

    result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
	    (BYTE *) Tcl_DStringValue(&data), &length);
    while (result == ERROR_MORE_DATA) {
	/*
	 * The Windows docs say that in this error case, we just need to
	 * expand our buffer and request more data. Required for
	 * HKEY_PERFORMANCE_DATA
	 */

	length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2);
	Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1));
	result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
		NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
    }
    Tcl_DStringFree(&buf);
    RegCloseKey(key);
    if (result != ERROR_SUCCESS) {
	Tcl_AppendResult(interp, "unable to get value \"",
		Tcl_GetString(valueNameObj), "\" from key \"",
		Tcl_GetString(keyNameObj), "\": ", NULL);
	AppendSystemError(interp, result);
	Tcl_DStringFree(&data);
	return TCL_ERROR;
    }

    /*
     * If the data is a 32-bit quantity, store it as an integer object. If it
     * is a multi-string, store it as a list of strings. For null-terminated
     * strings, append up the to first null. Otherwise, store it as a binary
     * string.
     */

    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
	Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type,
		*((DWORD*) Tcl_DStringValue(&data)))));
    } else if (type == REG_MULTI_SZ) {
	char *p = Tcl_DStringValue(&data);
	char *end = Tcl_DStringValue(&data) + length;
	Tcl_Obj *resultPtr = Tcl_NewObj();

	/*
	 * Multistrings are stored as an array of null-terminated strings,
	 * terminated by two null characters. Also do a bounds check in case
	 * we get bogus data.
	 */

	while (p < end 	&& ((regWinProcs->useWide)
		? *((Tcl_UniChar *)p) : *p) != 0) {
	    Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
	    Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(Tcl_DStringValue(&buf),
			    Tcl_DStringLength(&buf)));
	    if (regWinProcs->useWide) {
		Tcl_UniChar* up = (Tcl_UniChar*) p;
		while (*up++ != 0) {}
		p = (char*) up;
	    } else {
		while (*p++ != '\0') {}
	    }
	    Tcl_DStringFree(&buf);
	}
	Tcl_SetObjResult(interp, resultPtr);
    } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);


	Tcl_DStringResult(interp, &buf);
    } else {
	/*
	 * Save binary data as a byte array.
	 */

	Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
		(BYTE *) Tcl_DStringValue(&data), (int) length));
    }
    Tcl_DStringFree(&data);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * GetValueNames --
 *
 *	This function enumerates the values of the a given key. If the
 *	optional pattern is supplied, then only value names that match the
 *	pattern will be returned.
 *
 * Results:
 *	Returns the list of value names in the result object of the
 *	interpreter, or an error message on failure.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetValueNames(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Key to enumerate. */
    Tcl_Obj *patternObj)	/* Optional match pattern. */
{
    HKEY key;
    Tcl_Obj *resultPtr;
    DWORD index, size, result;
    Tcl_DString buffer, ds;
    char *pattern, *name;

    /*
     * Attempt to open the key for enumeration.
     */

    if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
	    != TCL_OK) {
	return TCL_ERROR;
    }

    resultPtr = Tcl_NewObj();



















    Tcl_DStringInit(&buffer);
    Tcl_DStringSetLength(&buffer,
	    (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH));
    index = 0;
    result = TCL_OK;

    if (patternObj) {
	pattern = Tcl_GetString(patternObj);
    } else {
	pattern = NULL;
    }

    /*
     * Enumerate the values under the given subkey until we get an error,
     * indicating the end of the list. Note that we need to reset size after
     * each iteration because RegEnumValue smashes the old value.
     */

    size = MAX_KEY_LENGTH;
    while ((*regWinProcs->regEnumValueProc)(key, index,
	    Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
	    == ERROR_SUCCESS) {

	if (regWinProcs->useWide) {
	    size *= 2;
	}

	Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size,
		&ds);
	name = Tcl_DStringValue(&ds);
	if (!pattern || Tcl_StringMatch(name, pattern)) {
	    result = Tcl_ListObjAppendElement(interp, resultPtr,
		    Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
	    if (result != TCL_OK) {
		Tcl_DStringFree(&ds);
		break;
	    }
	}
	Tcl_DStringFree(&ds);

	index++;
	size = MAX_KEY_LENGTH;
    }
    Tcl_SetObjResult(interp, resultPtr);
    Tcl_DStringFree(&buffer);


    RegCloseKey(key);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * OpenKey --
 *
 *	This function opens the specified key. This function is a simple
 *	wrapper around ParseKeyName and OpenSubKey.
 *
 * Results:
 *	Returns the opened key in the keyPtr argument and a Tcl result code.

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

    buffer = ckalloc((unsigned int) length + 1);
    strcpy(buffer, keyName);

    result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
    if (result == TCL_OK) {
	result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
	if (result != ERROR_SUCCESS) {
	    Tcl_SetObjResult(interp,
		    Tcl_NewStringObj("unable to open key: ", -1));
	    AppendSystemError(interp, result);
	    result = TCL_ERROR;
	} else {
	    result = TCL_OK;
	}
    }

    ckfree(buffer);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * OpenSubKey --
 *
 *	This function opens a given subkey of a root key on the specified
 *	host.
 *
 * Results:
 *	Returns the opened key in the keyPtr and a Windows error code as the
 *	return value.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	Tcl_DStringFree(&buf);
	if (result != ERROR_SUCCESS) {
	    return result;
	}
    }

    /*
     * Now open the specified key with the requested permissions. Note that
     * this key must be closed by the caller.
     */

    keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
    if (flags & REG_CREATE) {
	DWORD create;
	result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
		REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);

    } else if (rootKey == HKEY_PERFORMANCE_DATA) {
	/*
	 * Here we fudge it for this special root key. See MSDN for more info

	 * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
	 */
	*keyPtr = HKEY_PERFORMANCE_DATA;
	result = ERROR_SUCCESS;
    } else {
	result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
		keyPtr);

    }
    Tcl_DStringFree(&buf);

    /*
     * Be sure to close the root key since we are done with it now.
     */

    if (hostName) {
	RegCloseKey(rootKey);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseKeyName --
 *
 *	This function parses a key name into the host, root, and subkey parts.

 *
 * Results:
 *	The pointers to the start of the host and subkey names are returned in
 *	the hostNamePtr and keyNamePtr variables. The specified root HKEY is

 *	returned in rootKeyPtr. Returns a standard Tcl result.

 *
 * Side effects:
 *	Modifies the name string by inserting nulls.
 *
 *----------------------------------------------------------------------
 */

static int
ParseKeyName(
    Tcl_Interp *interp,		/* Current interpreter. */
    char *name,
    char **hostNamePtr,
    HKEY *rootKeyPtr,
    char **keyNamePtr)
{
    char *rootName;
    int result, index;
    Tcl_Obj *rootObj;

    /*
     * Split the key into host and root portions.
     */

    *hostNamePtr = *keyNamePtr = rootName = NULL;
    if (name[0] == '\\') {
	if (name[1] == '\\') {
	    *hostNamePtr = name;
	    for (rootName = name+2; *rootName != '\0'; rootName++) {
		if (*rootName == '\\') {
		    *rootName++ = '\0';
		    break;
		}
	    }
	}
    } else {
	rootName = name;
    }
    if (!rootName) {
	Tcl_AppendResult(interp, "bad key \"", name,
		"\": must start with a valid root", NULL);
	return TCL_ERROR;
    }

    /*
     * Split the root into root and subkey portions.
     */

}

/*
 *----------------------------------------------------------------------
 *
 * RecursiveDeleteKey --
 *
 *	This function recursively deletes all the keys below a starting key.
 *	Although Windows 95 does this automatically, we still need to do this
 *	for Windows NT.
 *
 * Results:
 *	Returns a Windows error code.
 *
 * Side effects:
 *	Deletes all of the keys and values below the given key.
 *
 *----------------------------------------------------------------------
 */

static DWORD
RecursiveDeleteKey(
    HKEY startKey,		/* Parent of key to be deleted. */
    CONST char *keyName)	/* Name of key to be deleted in external
				 * encoding, not UTF. */
{
    DWORD result, size;
    Tcl_DString subkey;
    HKEY hKey;

    /*
     * Do not allow NULL or empty key name.
     */

    if (!keyName || *keyName == '\0') {
	return ERROR_BADKEY;
    }

    result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
	    KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
    if (result != ERROR_SUCCESS) {
	return result;
    }







    Tcl_DStringInit(&subkey);
    Tcl_DStringSetLength(&subkey,
	    (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH));

    while (result == ERROR_SUCCESS) {
	/*
	 * Always get index 0 because key deletion changes ordering.
	 */

	size = MAX_KEY_LENGTH;
	result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
		Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
	if (result == ERROR_NO_MORE_ITEMS) {
	    result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
	    break;
	} else if (result == ERROR_SUCCESS) {
	    result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
	}
    }
    Tcl_DStringFree(&subkey);
    RegCloseKey(hKey);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SetValue --
 *
 *	This function sets the contents of a registry value. If the key or
 *	value does not exist, it will be created. If it does exist, then the
 *	data and type will be replaced.
 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	May create new keys or values.
 *
 *----------------------------------------------------------------------
 */

static int
SetValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Obj *keyNameObj,	/* Name of key. */
    Tcl_Obj *valueNameObj,	/* Name of value to set. */
    Tcl_Obj *dataObj,		/* Data to be written. */
    Tcl_Obj *typeObj)		/* Type of data to be written. */
{
    int type;
    DWORD result;
    HKEY key;
    int length;
    char *valueName;

    Tcl_DString nameBuf;

    if (typeObj == NULL) {
	type = REG_SZ;
    } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
	    0, (int *) &type) != TCL_OK) {
	if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_ResetResult(interp);
    }
    if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
	return TCL_ERROR;
    }

    valueName = Tcl_GetStringFromObj(valueNameObj, &length);
    valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);


    if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
	int value;

	if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	value = ConvertDWORD((DWORD)type, (DWORD)value);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
		(DWORD) type, (BYTE *) &value, sizeof(DWORD));
    } else if (type == REG_MULTI_SZ) {
	Tcl_DString data, buf;
	int objc, i;
	Tcl_Obj **objv;

	if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
	    RegCloseKey(key);
	    Tcl_DStringFree(&nameBuf);
	    return TCL_ERROR;
	}

	/*
	 * Append the elements as null terminated strings. Note that we must
	 * not assume the length of the string in case there are embedded
	 * nulls, which aren't allowed in REG_MULTI_SZ values.
	 */

	Tcl_DStringInit(&data);
	for (i = 0; i < objc; i++) {
	    Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);

	    /*
	     * Add a null character to separate this value from the next. We
	     * accomplish this by growing the string by one byte. Since the
	     * DString always tacks on an extra null byte, the new byte will
	     * already be set to null.
	     */

	    Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
	}

	Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
		&buf);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
                (DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
		(DWORD) Tcl_DStringLength(&buf));
	Tcl_DStringFree(&data);
	Tcl_DStringFree(&buf);
    } else if (type == REG_SZ || type == REG_EXPAND_SZ) {
	Tcl_DString buf;
	CONST char *data = Tcl_GetStringFromObj(dataObj, &length);

	data = Tcl_WinUtfToTChar(data, length, &buf);

	/*
	 * Include the null in the length, padding if needed for Unicode.
	 */

	if (regWinProcs->useWide) {
	    Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
	}
	length = Tcl_DStringLength(&buf) + 1;

	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
                (DWORD) type, (BYTE *) data, (DWORD) length);
	Tcl_DStringFree(&buf);
    } else {
	BYTE *data;

	/*
	 * Store binary data in the registry.
	 */

	data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length);
	result = (*regWinProcs->regSetValueExProc)(key, valueName, 0,
                (DWORD) type, data, (DWORD) length);
    }

    Tcl_DStringFree(&nameBuf);
    RegCloseKey(key);

    if (result != ERROR_SUCCESS) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("unable to set value: ", -1));
	AppendSystemError(interp, result);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * BroadcastValue --
 *
 *	This function broadcasts a WM_SETTINGCHANGE message to indicate to
 *	other programs that we have changed the contents of a registry value.

 *
 * Results:
 *	Returns a normal Tcl result.
 *
 * Side effects:
 *	Will cause other programs to reload their system settings.
 *
 *----------------------------------------------------------------------
 */

static int
BroadcastValue(
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[])	/* Argument values. */
{
    LRESULT result;
    DWORD_PTR sendResult;
    UINT timeout = 3000;
    int len;
    CONST char *str;
    Tcl_Obj *objPtr;

    if ((objc != 3) && (objc != 5)) {
	Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	return TCL_ERROR;
    }

    if (objc > 3) {
	str = Tcl_GetStringFromObj(objv[3], &len);
	if ((len < 2) || (*str != '-')
		|| strncmp(str, "-timeout", (size_t) len)) {
	    Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
	    return TCL_ERROR;
	}
	if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    str = Tcl_GetStringFromObj(objv[2], &len);
    if (len == 0) {
	str = NULL;
    }

    /*
     * Use the ignore the result.
     */

    result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
	    (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);

    objPtr = Tcl_NewObj();
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
    Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
    Tcl_SetObjResult(interp, objPtr);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AppendSystemError --
 *
 *	This routine formats a Windows system error message and places it into
 *	the interpreter result.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
AppendSystemError(
    Tcl_Interp *interp,		/* Current interpreter. */
    DWORD error)		/* Result code from error. */
{
    int length;
    WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr;
    char *msg;
    char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
    Tcl_DString ds;
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

    if (Tcl_IsShared(resultPtr)) {
	resultPtr = Tcl_DuplicateObj(resultPtr);
    }
    length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
	    | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
	    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr,
	    0, NULL);
    if (length == 0) {
	char *msgPtr;

	length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
		| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
		MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,

	msg = Tcl_DStringValue(&ds);
	length = Tcl_DStringLength(&ds);

	/*
	 * Trim the trailing CR/LF from the system message.
	 */

	if (msg[length-1] == '\n') {
	    msg[--length] = 0;
	}
	if (msg[length-1] == '\r') {
	    msg[--length] = 0;
	}
    }

    sprintf(id, "%ld", error);
    Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL);
    Tcl_AppendToObj(resultPtr, msg, length);
    Tcl_SetObjResult(interp, resultPtr);

    if (length != 0) {
	Tcl_DStringFree(&ds);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertDWORD --
 *
 *	This function determines whether a DWORD needs to be byte swapped, and
 *	returns the appropriately swapped value.
 *
 * Results:
 *	Returns a converted DWORD.
 *
 * Side effects:
 *	None.
 *

    DWORD order = 1;
    DWORD localType;

    /*
     * Check to see if the low bit is in the first byte.
     */

    localType = (*((char*) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
    return (type != localType) ? (DWORD) SWAPLONG(value) : value;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */