From 99ea4405aed6acebfa01e202fbf947decdfae5ee Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Apr 2013 07:28:08 +0000 Subject: Update dde to version 1.3.3. Update registry to version 1.2.2. (the same as distributed with Tcl 8.5.14) --- ChangeLog | 7 + library/dde/pkgIndex.tcl | 4 +- library/reg/pkgIndex.tcl | 8 +- tests/winDde.test | 94 ++++--- tools/tcl.wse.in | 124 ++++----- unix/Makefile.in | 18 +- unix/configure | 2 +- unix/tcl.m4 | 2 +- win/configure | 8 +- win/configure.in | 8 +- win/makefile.bc | 8 +- win/makefile.vc | 4 +- win/rules.vc | 8 +- win/tclWinDde.c | 433 ++++++++++++++++++++++++-------- win/tclWinReg.c | 639 +++++++++++++++++++++++++---------------------- 15 files changed, 826 insertions(+), 541 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4e159a7..11efb0f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2013-04-25 Jan Nijtmans + + * 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 * generic/tclDecls.h: Implement Tcl_Pkg* functions as diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 1450276..114dee6 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded dde 1.2.5 [list load [file join $dir tcldde12g.dll] dde] + package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde] } else { - package ifneeded dde 1.2.5 [list load [file join $dir tcldde12.dll] dde] + package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde] } diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 40032a5..1241f2a 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded registry 1.1.5 \ - [list load [file join $dir tclreg11g.dll] registry] + package ifneeded registry 1.2.2 \ + [list load [file join $dir tclreg12g.dll] registry] } else { - package ifneeded registry 1.1.5 \ - [list load [file join $dir tclreg11.dll] registry] + package ifneeded registry 1.2.2 \ + [list load [file join $dir tclreg12.dll] registry] } diff --git a/tests/winDde.test b/tests/winDde.test index 85fb5a6..454e76d 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -2,7 +2,7 @@ # # 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. +# generates output for errors. No output means no errors were found. # # Copyright (c) 1999 by Scriptics Corporation. # @@ -66,6 +66,8 @@ proc createChildProcess { ddeServerName } { 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} @@ -84,6 +86,8 @@ test winDde-2.3 {Checking for existence, with only the service specified} \ expr [llength [dde services TclEval {}]] >= 1 } 1 +# ------------------------------------------------------------------------- + test winDde-3.1 {DDE execute locally} {pcOnly} { set a "" dde execute TclEval self {set a "foo"} @@ -114,47 +118,48 @@ test winDde-3.5 {DDE request locally} {pcOnly} { dde request -binary TclEval self a } "foo\x00" +# ------------------------------------------------------------------------- + test winDde-4.1 {DDE execute remotely} {stdio pcOnly} { - list [catch { - set a "" - set child [createChildProcess child] - dde execute TclEval child {set a "foo"} - dde execute TclEval child {set done 1} - set a - } err] $err -} [list 0 ""] - -test winDde-4.2 {DDE execute remotely} {stdio pcOnly} { - list [catch { - set a "" - set child [createChildProcess child] - dde execute -async TclEval child {set a "foo"} - after 400 {set ::_dde_forever 1} ; vwait ::_dde_forever; #update - dde execute TclEval child {set done 1} - set a - } err] $err -} [list 0 ""] - -test winDde-4.3 {DDE request locally} {stdio pcOnly} { - list [catch { - set a "" - set child [createChildProcess child] - dde execute TclEval child {set a "foo"} - set a [dde request TclEval child a] - dde execute TclEval child {set done 1} - set a - } err] $err -} [list 0 foo] - -test winDde-4.4 {DDE eval locally} {stdio pcOnly} { - list [catch { - set a "" - set child [createChildProcess child] - set a [dde eval child set a "foo"] - dde execute TclEval child {set done 1} - set a - } err] $err -} [list 0 foo] + 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 @@ -175,7 +180,14 @@ 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: diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index 1dceec0..a4d8ede 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -162,7 +162,7 @@ item: Custom Dialog Set Title Danish=Velkommen Title Dutch=Welkom Title Norwegian=Velkommen - Title Swedish=Välkommen + Title Swedish=V�lkommen Width=273 Height=250 Font Name=Helv @@ -235,7 +235,7 @@ item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -250,7 +250,7 @@ item: Custom Dialog Set Text=Welcome! Text French=Bienvenue ! Text German=Willkommen! - Text Spanish=¡Bienvenido! + Text Spanish=�Bienvenido! Text Italian=Benvenuti! end item: Push Button @@ -271,8 +271,8 @@ item: Custom Dialog Set Create Flags=01010000000000010000000000000000 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -295,14 +295,14 @@ item: Custom Dialog Set 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 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=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 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 @@ -320,7 +320,7 @@ item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -345,8 +345,8 @@ item: Custom Dialog Set Flags=0000000000000001 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -371,8 +371,8 @@ item: Custom Dialog Set 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 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 @@ -384,7 +384,7 @@ item: Custom Dialog Set 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 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%. @@ -419,8 +419,8 @@ item: Custom Dialog Set end item: Dialog Title=Select Destination Directory - Title French=Sélectionner le répertoire de destination - Title German=Zielverzeichnis wählen + 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 @@ -468,7 +468,7 @@ remarked item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -492,8 +492,8 @@ remarked item: Custom Dialog Set Create Flags=01010000000000010000000000000000 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -518,8 +518,8 @@ remarked item: Custom Dialog Set 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 French=S�lectionner les composants + Text German=Komponenten ausw�hlen Text Spanish=Seleccione componentes Text Italian=Selezionare i componenti end @@ -562,7 +562,7 @@ remarked item: Custom Dialog Set 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 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 @@ -584,7 +584,7 @@ item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -608,8 +608,8 @@ item: Custom Dialog Set Create Flags=01010000000000010000000000000000 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -634,8 +634,8 @@ item: Custom Dialog Set 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 French=S�lectionner les composants + Text German=Komponenten ausw�hlen Text Spanish=Seleccione componentes Text Italian=Selezionare i componenti end @@ -709,7 +709,7 @@ item: Custom Dialog Set 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 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 @@ -722,7 +722,7 @@ item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -747,8 +747,8 @@ item: Custom Dialog Set Flags=0000000000000001 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -773,7 +773,7 @@ item: Custom Dialog Set 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 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 @@ -782,8 +782,8 @@ item: Custom Dialog Set 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 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 @@ -807,7 +807,7 @@ item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -831,8 +831,8 @@ item: Custom Dialog Set Create Flags=01010000000000010000000000000000 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -857,9 +857,9 @@ item: Custom Dialog Set 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 French=Pr�t � installer ! Text German=Installationsbereit! - Text Spanish=¡Preparado para la instalación! + Text Spanish=�Preparado para la instalaci�n! Text Italian=Pronto per l'installazione! end item: Static @@ -868,16 +868,16 @@ item: Custom Dialog Set 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=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 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 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 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 @@ -1583,22 +1583,22 @@ item: Install File end item: Install File Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl - Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl + Destination=%MAINDIR%\lib\tcl%VER%\reg1.2\pkgIndex.tcl Flags=0000000000000010 end item: Install File - Source=${__TCLBASEDIR__}\win\release\tclreg10.dll - Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\tclreg10.dll + 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.2\pkgIndex.tcl + Destination=%MAINDIR%\lib\tcl%VER%\dde1.3\pkgIndex.tcl Flags=0000000000000010 end item: Install File - Source=${__TCLBASEDIR__}\win\release\tcldde12.dll - Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde12.dll + Source=${__TCLBASEDIR__}\win\release\tcldde13.dll + Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde13.dll Flags=0000000000000010 end item: Install File @@ -2257,7 +2257,7 @@ item: Custom Dialog Set Title=%APPTITLE% Installation Title French=Installation de %APPTITLE% Title German=Installation von %APPTITLE% - Title Spanish=Instalación de %APPTITLE% + Title Spanish=Instalaci�n de %APPTITLE% Title Italian=Installazione di %APPTITLE% Width=271 Height=224 @@ -2281,8 +2281,8 @@ item: Custom Dialog Set Create Flags=01010000000000010000000000000000 Text=< &Back Text French=< &Retour - Text German=< &Zurück - Text Spanish=< &Atrás + Text German=< &Zur�ck + Text Spanish=< &Atr�s Text Italian=< &Indietro end item: Push Button @@ -2309,9 +2309,9 @@ item: Custom Dialog Set 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 French=Installation termin�e ! Text German=Die Installation ist abgeschlossen! - Text Spanish=¡Instalación terminada! + Text Spanish=�Instalaci�n terminada! Text Italian=Installazione completata! end item: Static @@ -2324,16 +2324,16 @@ item: Custom Dialog Set 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=%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=%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 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 diff --git a/unix/Makefile.in b/unix/Makefile.in index 72fb215..0752106 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -648,7 +648,7 @@ install-binaries: binaries @INSTALL_STUB_LIB@ ; \ fi @if test "x$(DLL_INSTALL_DIR)" = "x$(BIN_INSTALL_DIR)"; then\ - for i in dde1.2 reg1.1; do \ + 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;\ @@ -656,14 +656,14 @@ install-binaries: binaries else true;\ fi;\ done;\ - echo "Installing tcldde12.dll";\ - $(INSTALL_DATA) "$(TOP_DIR)/library/dde/pkgIndex.tcl" "$(LIB_INSTALL_DIR)/dde1.2";\ - $(INSTALL_LIBRARY) "$(TOP_DIR)/win/tcldde12.dll" "$(LIB_INSTALL_DIR)/dde1.2";\ - chmod 555 "$(LIB_INSTALL_DIR)/dde1.2/tcldde12.dll";\ - echo "Installing tclreg11.dll";\ - $(INSTALL_DATA) "$(TOP_DIR)/library/reg/pkgIndex.tcl" "$(LIB_INSTALL_DIR)/reg1.1";\ - $(INSTALL_LIBRARY) "$(TOP_DIR)/win/tclreg11.dll" "$(LIB_INSTALL_DIR)/reg1.1";\ - chmod 555 "$(LIB_INSTALL_DIR)/reg1.1/tclreg11.dll";\ + 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@ diff --git a/unix/configure b/unix/configure index 39a9e1c..80d747c 100755 --- a/unix/configure +++ b/unix/configure @@ -2884,7 +2884,7 @@ echo "$ac_t""$ac_cv_cygwin" 1>&6 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/tcldde12.dll" -a ! -f "../win/tk84.dll"; then + 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 ;; diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 360b3a1..db64bbe 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1229,7 +1229,7 @@ dnl AC_CHECK_TOOL(AR, ar) 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/tcldde12.dll" -a ! -f "../win/tk84.dll"; then + 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 ;; diff --git a/win/configure b/win/configure index 51a86a7..0f36f24 100755 --- a/win/configure +++ b/win/configure @@ -541,14 +541,14 @@ TCL_MINOR_VERSION=4 TCL_PATCH_LEVEL=".19" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.2 +TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=2 +TCL_DDE_MINOR_VERSION=3 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.1 +TCL_REG_VERSION=1.2 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=1 +TCL_REG_MINOR_VERSION=2 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION #------------------------------------------------------------------------ diff --git a/win/configure.in b/win/configure.in index 635469b..99dc334 100644 --- a/win/configure.in +++ b/win/configure.in @@ -12,14 +12,14 @@ TCL_MINOR_VERSION=4 TCL_PATCH_LEVEL=".19" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.2 +TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=2 +TCL_DDE_MINOR_VERSION=3 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.1 +TCL_REG_VERSION=1.2 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=1 +TCL_REG_MINOR_VERSION=2 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION #------------------------------------------------------------------------ diff --git a/win/makefile.bc b/win/makefile.bc index 3c0ea73..6a3cd9d 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -110,11 +110,11 @@ STUBPREFIX = $(NAMEPREFIX)stub DOTVERSION = 8.4 VERSION = 84 -DDEVERSION = 12 -DDEDOTVERSION = 1.2 +DDEVERSION = 13 +DDEDOTVERSION = 1.3 -REGVERSION = 11 -REGDOTVERSION = 1.1 +REGVERSION = 12 +REGDOTVERSION = 1.2 BINROOT = .. !IF "$(NODEBUG)" == "1" diff --git a/win/makefile.vc b/win/makefile.vc index 94a585b..41a0006 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -159,10 +159,10 @@ STUBPREFIX = $(PROJECT)stub DOTVERSION = 8.4 VERSION = $(DOTVERSION:.=) -DDEDOTVERSION = 1.2 +DDEDOTVERSION = 1.3 DDEVERSION = $(DDEDOTVERSION:.=) -REGDOTVERSION = 1.1 +REGDOTVERSION = 1.2 REGVERSION = $(REGDOTVERSION:.=) BINROOT = . diff --git a/win/rules.vc b/win/rules.vc index 425f5fb..38e8175 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -477,8 +477,8 @@ 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\tclreg11$(SUFX:t=).lib" -TCLDDELIB = "$(_INSTALLDIR)\lib\tcldde12$(SUFX:t=).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 @@ -486,8 +486,8 @@ 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)\tclreg11$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde12$(SUFX:t=).lib" +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 diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 4aa6f71..eef5caa 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -10,6 +10,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include "tclInt.h" #include "tclPort.h" #include #include @@ -34,6 +35,7 @@ typedef struct RegisteredInterp { /* 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; @@ -49,6 +51,14 @@ typedef struct 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 @@ -69,23 +79,33 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.2.5" #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); @@ -97,6 +117,7 @@ static int DdeObjCmd(ClientData clientData, Tcl_Obj *const objv[]); EXTERN int Dde_Init(Tcl_Interp *interp); +EXTERN int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -124,7 +145,34 @@ Dde_Init( Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); + 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; } /* @@ -181,7 +229,7 @@ Initialize(void) ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, CP_WINANSI); + TCL_DDE_SERVICE_NAME, 0); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { ddeIsServer = 0; @@ -218,13 +266,19 @@ Initialize(void) static const char * DdeSetServerName( Tcl_Interp *interp, - const char *name /* The name that will be used to refer to the + 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); /* @@ -263,7 +317,67 @@ DdeSetServerName( 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. @@ -271,10 +385,18 @@ DdeSetServerName( riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = ckalloc((unsigned int) strlen(name) + 1); + 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, name); + strcpy(riPtr->name, actualName); + + if (Tcl_IsSafe(interp)) { + Tcl_ExposeCommand(interp, "dde", "dde"); + } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, (ClientData) riPtr, DeleteProc); @@ -295,6 +417,38 @@ DdeSetServerName( /* *---------------------------------------------------------------------- * + * 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. @@ -333,6 +487,9 @@ DeleteProc( } } ckfree(riPtr->name); + if (riPtr->handlerPtr) { + Tcl_DecrRefCount(riPtr->handlerPtr); + } Tcl_EventuallyFree(clientData, TCL_DYNAMIC); } @@ -365,10 +522,35 @@ ExecuteRemoteObject( Tcl_Obj *ddeObjectPtr) /* The object to execute. */ { Tcl_Obj *returnPackagePtr; - int result; + 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); - result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); - returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_NewIntObj(result)); Tcl_ListObjAppendElement(NULL, returnPackagePtr, @@ -549,21 +731,27 @@ DdeServerProc( ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); } 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); + 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 { - returnString = (char *) - Tcl_GetUnicodeFromObj(variableObjPtr, &len); - len = 2 * len + 1; + ddeReturn = NULL; } - ddeReturn = DdeCreateDataHandle(ddeInstance, - (BYTE *) returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); - } else { - ddeReturn = NULL; } } Tcl_DStringFree(&dString); @@ -723,8 +911,8 @@ MakeDdeConnection( HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINANSI); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINANSI); + ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0); + ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -762,21 +950,9 @@ MakeDdeConnection( *---------------------------------------------------------------------- */ -typedef struct ddeEnumServices { - Tcl_Interp *interp; - int result; - ATOM service; - ATOM topic; - HWND hwnd; -} ddeEnumServices; - -static LRESULT CALLBACK -DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); -static LRESULT -DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam); - static int -DdeCreateClient(ddeEnumServices *es) +DdeCreateClient( + struct DdeEnumServices *es) { WNDCLASSEX wc; static const char *szDdeClientClassName = "TclEval client class"; @@ -786,7 +962,7 @@ DdeCreateClient(ddeEnumServices *es) wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; - wc.cbWndExtra = sizeof(ddeEnumServices*); + wc.cbWndExtra = sizeof(struct DdeEnumServices *); /* * Register and create the callback window. @@ -808,8 +984,9 @@ DdeClientWindowProc( switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - ddeEnumServices *es = - (ddeEnumServices*) lpcs->lpCreateParams; + struct DdeEnumServices *es = + (struct DdeEnumServices *) lpcs->lpCreateParams; + #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); #else @@ -833,25 +1010,24 @@ DdeServicesOnAck( HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); - ddeEnumServices *es; + struct DdeEnumServices *es; char sz[255]; #ifdef _WIN64 - es = (ddeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else - es = (ddeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + 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(es->interp, matchPtr, - Tcl_NewStringObj(sz, -1)); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); GlobalGetAtomName(topic, sz, 255); - Tcl_ListObjAppendElement(es->interp, matchPtr, - Tcl_NewStringObj(sz, -1)); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); /* * Adding the hwnd as a third list element provides a unique @@ -864,8 +1040,13 @@ DdeServicesOnAck( * Tcl_NewLongObj((long)hwndRemote)); */ - Tcl_ListObjAppendElement(es->interp, - Tcl_GetObjResult(es->interp), matchPtr); + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + } + if (Tcl_ListObjAppendElement(es->interp, resultPtr, + matchPtr) == TCL_OK) { + Tcl_SetObjResult(es->interp, resultPtr); + } } /* @@ -882,7 +1063,7 @@ DdeEnumWindowsCallback( LPARAM lParam) { DWORD_PTR dwResult = 0; - ddeEnumServices *es = (ddeEnumServices *) lParam; + struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, @@ -896,7 +1077,7 @@ DdeGetServicesList( const char *serviceName, const char *topicName) { - ddeEnumServices es; + struct DdeEnumServices es; es.interp = interp; es.result = TCL_OK; @@ -989,10 +1170,16 @@ DdeObjCmd( static const char *ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", (char *) NULL}; - enum { + 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 }; @@ -1000,15 +1187,14 @@ DdeObjCmd( "-binary", NULL }; - int index, length, argIndex; - int async = 0, binary = 0; - int result = TCL_OK, firstArg = 0; + 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; + Tcl_Obj *objPtr, *handlerPtr = NULL; /* * Initialize DDE server/client @@ -1024,24 +1210,59 @@ DdeObjCmd( return TCL_ERROR; } - switch (index) { + switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: - if ((objc != 3) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "servername ?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 - 1); + firstArg = (objc == i) ? 1 : i; break; case DDE_EXECUTE: if (objc == 5) { firstArg = 2; break; } else if (objc == 6) { - int dummy; if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, - &dummy) == TCL_OK) { - async = 1; + &argIndex) == TCL_OK) { + flags |= DDE_FLAG_ASYNC; firstArg = 3; break; } @@ -1066,7 +1287,7 @@ DdeObjCmd( int dummy; if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, &dummy) == TCL_OK) { - binary = 1; + flags |= DDE_FLAG_BINARY; firstArg = 3; break; } @@ -1098,7 +1319,7 @@ DdeObjCmd( if (objc < 5) { goto wrongDdeEvalArgs; } - async = 1; + flags |= DDE_FLAG_ASYNC; firstArg++; } break; @@ -1130,9 +1351,10 @@ DdeObjCmd( } } - switch (index) { + switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: - serviceName = DdeSetServerName(interp, serviceName); + serviceName = DdeSetServerName(interp, serviceName, flags, + handlerPtr); if (serviceName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); } else { @@ -1152,12 +1374,8 @@ DdeObjCmd( break; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); - if (ddeService) { - DdeFreeStringHandle(ddeInstance, ddeService); - } - if (ddeTopic) { - DdeFreeStringHandle(ddeInstance, ddeTopic); - } + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { SetDdeError(interp); @@ -1168,7 +1386,7 @@ DdeObjCmd( ddeData = DdeCreateDataHandle(ddeInstance, dataString, (DWORD) dataLength+1, 0, 0, CF_TEXT, 0); if (ddeData != NULL) { - if (async) { + if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); @@ -1198,12 +1416,8 @@ DdeObjCmd( goto cleanup; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); - if (ddeService) { - DdeFreeStringHandle(ddeInstance, ddeService); - } - if (ddeTopic) { - DdeFreeStringHandle(ddeInstance, ddeTopic); - } + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { SetDdeError(interp); @@ -1222,9 +1436,9 @@ DdeObjCmd( DWORD tmp; const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); - if (binary) { - returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, - (int) tmp); + if (flags & DDE_FLAG_BINARY) { + returnObjPtr = + Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { if (tmp && !dataString[tmp-1]) { --tmp; @@ -1259,12 +1473,8 @@ DdeObjCmd( &length); hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); - if (ddeService) { DdeFreeStringHandle(ddeInstance, ddeService); - } - if (ddeTopic) { DdeFreeStringHandle(ddeInstance, ddeTopic); - } if (hConv == NULL) { SetDdeError(interp); @@ -1302,8 +1512,8 @@ DdeObjCmd( goto cleanup; } - objc -= (async + 3); - objv += (async + 3); + objc -= firstArg + 1; + objv += firstArg + 1; /* * See if the target interpreter is local. If so, execute the command @@ -1341,11 +1551,34 @@ DdeObjCmd( * referring to deallocated objects. */ - if (objc == 1) { - result = Tcl_EvalObjEx(sendInterp, objv[0], - TCL_EVAL_GLOBAL); - } else { - objPtr = Tcl_ConcatObj(objc, objv); + 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); @@ -1384,7 +1617,8 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", -1)); + Tcl_NewStringObj("invalid data returned from server", + -1)); result = TCL_ERROR; goto cleanup; } @@ -1394,7 +1628,7 @@ DdeObjCmd( ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); - if (async) { + if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); @@ -1416,10 +1650,9 @@ DdeObjCmd( if (ddeData == 0) { SetDdeError(interp); result = TCL_ERROR; - goto cleanup; } - if (async == 0) { + if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; /* diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 701edfb..a6ce2ce 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -1,18 +1,22 @@ /* * 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. + * 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include +#include "tclInt.h" +#include "tclPort.h" +#ifdef _MSC_VER +# pragma comment (lib, "advapi32.lib") +#endif #include /* @@ -25,6 +29,14 @@ #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. */ @@ -32,15 +44,15 @@ #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. + * 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. + * The following tables contain the mapping from registry root names to the + * system predefined keys. */ static CONST char *rootKeyNames[] = { @@ -54,11 +66,12 @@ static const HKEY rootKeys[] = { 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. + * 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[] = { @@ -70,9 +83,9 @@ 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. + * 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 { @@ -80,7 +93,7 @@ typedef struct RegWinProcs { LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY); LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); + 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); @@ -90,9 +103,6 @@ typedef struct RegWinProcs { DWORD *, BYTE *, DWORD *); LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, HKEY *); - LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *); LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, BYTE *, DWORD *); LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, @@ -107,7 +117,7 @@ static RegWinProcs asciiProcs = { (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExA, + DWORD *)) RegCreateKeyExA, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, @@ -117,9 +127,6 @@ static RegWinProcs asciiProcs = { DWORD *, BYTE *, DWORD *)) RegEnumValueA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, HKEY *)) RegOpenKeyExA, - (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *)) RegQueryInfoKeyA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, BYTE *, DWORD *)) RegQueryValueExA, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, @@ -132,7 +139,7 @@ static RegWinProcs unicodeProcs = { (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExW, + DWORD *)) RegCreateKeyExW, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, @@ -142,9 +149,6 @@ static RegWinProcs unicodeProcs = { DWORD *, BYTE *, DWORD *)) RegEnumValueW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, HKEY *)) RegOpenKeyExW, - (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *, - DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, - FILETIME *)) RegQueryInfoKeyW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, BYTE *, DWORD *)) RegQueryValueExW, (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, @@ -160,6 +164,7 @@ 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); @@ -188,14 +193,15 @@ 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_Init(Tcl_Interp *interp); +EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- * * Registry_Init -- * - * This procedure initializes the registry command. + * This function initializes the registry command. * * Results: * A standard Tcl result. @@ -210,7 +216,9 @@ int Registry_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.0", 0)) { + Tcl_Command cmd; + + if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { return TCL_ERROR; } @@ -225,8 +233,80 @@ Registry_Init( regWinProcs = &asciiProcs; } - Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL); - return Tcl_PkgProvide(interp, "registry", "1.1.5"); + 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); } /* @@ -256,8 +336,7 @@ RegistryObjCmd( char *errString = NULL; static CONST char *subcommands[] = { - "broadcast", "delete", "get", "keys", "set", "type", "values", - (char *) NULL + "broadcast", "delete", "get", "keys", "set", "type", "values", NULL }; enum SubCmdIdx { BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx @@ -274,65 +353,64 @@ RegistryObjCmd( } 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; + 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. - */ + /* + * 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]); + if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + return TCL_ERROR; } - errString = "keyName ?pattern?"; - break; + 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; @@ -364,7 +442,6 @@ DeleteKey( HKEY rootKey, subkey; DWORD result; int length; - Tcl_Obj *resultPtr; Tcl_DString buf; /* @@ -375,15 +452,15 @@ DeleteKey( buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); - if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) - != TCL_OK) { + if (ParseKeyName(interp, buffer, &hostName, &rootKey, + &keyName) != TCL_OK) { ckfree(buffer); return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); if (*keyName == '\0') { - Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad key: cannot delete root keys", -1)); ckfree(buffer); return TCL_ERROR; } @@ -402,11 +479,11 @@ DeleteKey( ckfree(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; - } else { - Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); - AppendSystemError(interp, result); - return TCL_ERROR; } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to delete key: ", -1)); + AppendSystemError(interp, result); + return TCL_ERROR; } /* @@ -418,7 +495,8 @@ DeleteKey( Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { - Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -456,7 +534,6 @@ DeleteValue( char *valueName; int length; DWORD result; - Tcl_Obj *resultPtr; Tcl_DString ds; /* @@ -468,13 +545,12 @@ DeleteValue( return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); 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_AppendStringsToObj(resultPtr, "unable to delete value \"", + Tcl_AppendResult(interp, "unable to delete value \"", Tcl_GetString(valueNameObj), "\" from key \"", Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); @@ -491,13 +567,13 @@ DeleteValue( * * 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. + * 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. + * Returns the list of subkeys in the result object of the interpreter, + * or an error message on failure. * * Side effects: * None. @@ -513,9 +589,7 @@ GetKeyNames( { char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - DWORD subKeyCount; /* Number of subkeys to list */ - DWORD maxSubKeyLen; /* Maximum string length of any subkey */ - char *buffer; /* Buffer to hold the subkey name */ + 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 */ @@ -537,43 +611,24 @@ GetKeyNames( return TCL_ERROR; } - /* - * Determine how big a buffer is needed for enumerating subkeys, and - * how many subkeys there are - */ - - result = (*regWinProcs->regQueryInfoKeyProc) - (key, NULL, NULL, NULL, &subKeyCount, &maxSubKeyLen, NULL, NULL, - NULL, NULL, NULL, NULL); - if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, "unable to query key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - RegCloseKey(key); - return TCL_ERROR; - } - if (regWinProcs->useWide) { - buffer = ckalloc((maxSubKeyLen+1) * sizeof(WCHAR)); - } else { - buffer = ckalloc(maxSubKeyLen+1); - } - /* Enumerate the subkeys */ resultPtr = Tcl_NewObj(); - for (index = 0; index < subKeyCount; ++index) { - bufSize = maxSubKeyLen+1; + for (index = 0;; ++index) { + bufSize = MAX_KEY_LENGTH; result = (*regWinProcs->regEnumKeyExProc) (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, - "unable to enumerate subkeys of \"", - Tcl_GetString(keyNameObj), - "\": ", NULL); - AppendSystemError(interp, result); - result = TCL_ERROR; + 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) { @@ -599,7 +654,6 @@ GetKeyNames( Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */ } - ckfree(buffer); RegCloseKey(key); return result; } @@ -609,8 +663,8 @@ GetKeyNames( * * GetType -- * - * This function gets the type of a given registry value and - * places it in the interpreter result. + * This function gets the type of a given registry value and places it in + * the interpreter result. * * Results: * Returns a normal Tcl result. @@ -628,7 +682,6 @@ GetType( Tcl_Obj *valueNameObj) /* Name of value to get. */ { HKEY key; - Tcl_Obj *resultPtr; DWORD result; DWORD type; Tcl_DString ds; @@ -649,8 +702,6 @@ GetType( * Get the type of the value. */ - resultPtr = Tcl_GetObjResult(interp); - valueName = Tcl_GetStringFromObj(valueNameObj, &length); nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, @@ -659,7 +710,7 @@ GetType( RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"", + Tcl_AppendResult(interp, "unable to get type of value \"", Tcl_GetString(valueNameObj), "\" from key \"", Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); @@ -667,14 +718,14 @@ GetType( } /* - * Set the type into the result. Watch out for unknown types. - * If we don't know about the type, just use the numeric value. + * 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_SetIntObj(resultPtr, (int) type); + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { - Tcl_SetStringObj(resultPtr, typeNames[type], -1); + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); } return TCL_OK; } @@ -684,9 +735,8 @@ GetType( * * GetValue -- * - * This function gets the contents of a registry value and places - * a list containing the data and the type in the interpreter - * result. + * 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. @@ -707,7 +757,6 @@ GetValue( char *valueName; CONST char *nativeValue; DWORD result, length, type; - Tcl_Obj *resultPtr; Tcl_DString data, buf; int nameLen; @@ -715,16 +764,15 @@ GetValue( * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + 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. + * 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. @@ -734,8 +782,6 @@ GetValue( Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1; - resultPtr = Tcl_GetObjResult(interp); - valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); @@ -743,11 +789,12 @@ GetValue( (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 + * 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 *= 2; + + 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); @@ -755,7 +802,7 @@ GetValue( Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to get value \"", + Tcl_AppendResult(interp, "unable to get value \"", Tcl_GetString(valueNameObj), "\" from key \"", Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); @@ -764,26 +811,27 @@ GetValue( } /* - * 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 + * 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_SetIntObj(resultPtr, (int) ConvertDWORD(type, - *((DWORD*) Tcl_DStringValue(&data)))); + 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. + * terminated by two null characters. Also do a bounds check in case + * we get bogus data. */ - - while (p < end && ((regWinProcs->useWide) + + while (p < end && ((regWinProcs->useWide) ? *((Tcl_UniChar *)p) : *p) != 0) { Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, @@ -798,17 +846,17 @@ GetValue( } 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_SetStringObj(resultPtr, Tcl_DStringValue(&buf), - Tcl_DStringLength(&buf)); - Tcl_DStringFree(&buf); + Tcl_DStringResult(interp, &buf); } else { /* * Save binary data as a byte array. */ - Tcl_SetByteArrayObj(resultPtr, (BYTE *) Tcl_DStringValue(&data), (int) length); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (BYTE *) Tcl_DStringValue(&data), (int) length)); } Tcl_DStringFree(&data); return result; @@ -819,9 +867,9 @@ GetValue( * * 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. + * 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 @@ -841,7 +889,7 @@ GetValueNames( { HKEY key; Tcl_Obj *resultPtr; - DWORD index, size, maxSize, result; + DWORD index, size, result; Tcl_DString buffer, ds; char *pattern, *name; @@ -854,29 +902,10 @@ GetValueNames( return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); - - /* - * Query the key to determine the appropriate buffer size to hold the - * largest value name plus the terminating null. - */ - - result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL, - NULL, NULL, &index, &maxSize, NULL, NULL, NULL); - if (result != ERROR_SUCCESS) { - Tcl_AppendStringsToObj(resultPtr, "unable to query key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); - AppendSystemError(interp, result); - RegCloseKey(key); - result = TCL_ERROR; - goto done; - } - maxSize++; - - + resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); Tcl_DStringSetLength(&buffer, - (int) ((regWinProcs->useWide) ? maxSize*2 : maxSize)); + (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH)); index = 0; result = TCL_OK; @@ -888,11 +917,11 @@ GetValueNames( /* * 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. + * indicating the end of the list. Note that we need to reset size after + * each iteration because RegEnumValue smashes the old value. */ - size = maxSize; + size = MAX_KEY_LENGTH; while ((*regWinProcs->regEnumValueProc)(key, index, Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { @@ -901,7 +930,8 @@ GetValueNames( size *= 2; } - Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, + &ds); name = Tcl_DStringValue(&ds); if (!pattern || Tcl_StringMatch(name, pattern)) { result = Tcl_ListObjAppendElement(interp, resultPtr, @@ -914,11 +944,10 @@ GetValueNames( Tcl_DStringFree(&ds); index++; - size = maxSize; + size = MAX_KEY_LENGTH; } + Tcl_SetObjResult(interp, resultPtr); Tcl_DStringFree(&buffer); - - done: RegCloseKey(key); return result; } @@ -928,12 +957,11 @@ GetValueNames( * * OpenKey -- * - * This function opens the specified key. This function is a - * simple wrapper around ParseKeyName and OpenSubKey. + * 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. + * Returns the opened key in the keyPtr argument and a Tcl result code. * * Side effects: * None. @@ -962,8 +990,8 @@ OpenKey( if (result == TCL_OK) { result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); if (result != ERROR_SUCCESS) { - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - Tcl_AppendToObj(resultPtr, "unable to open key: ", -1); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to open key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -980,12 +1008,12 @@ OpenKey( * * OpenSubKey -- * - * This function opens a given subkey of a root key on the - * specified host. + * 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. + * Returns the opened key in the keyPtr and a Windows error code as the + * return value. * * Side effects: * None. @@ -1020,8 +1048,8 @@ OpenSubKey( } /* - * Now open the specified key with the requested permissions. Note - * that this key must be closed by the caller. + * 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); @@ -1029,19 +1057,16 @@ OpenSubKey( 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 { - 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); - } + result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode, + keyPtr); } Tcl_DStringFree(&buf); @@ -1060,15 +1085,12 @@ OpenSubKey( * * ParseKeyName -- * - * This function parses a key name into the host, root, and subkey - * parts. + * 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. - * + * 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. @@ -1086,7 +1108,7 @@ ParseKeyName( { char *rootName; int result, index; - Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp); + Tcl_Obj *rootObj; /* * Split the key into host and root portions. @@ -1107,7 +1129,7 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendStringsToObj(resultPtr, "bad key \"", name, + Tcl_AppendResult(interp, "bad key \"", name, "\": must start with a valid root", NULL); return TCL_ERROR; } @@ -1144,9 +1166,9 @@ ParseKeyName( * * 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. + * 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. @@ -1163,7 +1185,7 @@ RecursiveDeleteKey( CONST char *keyName) /* Name of key to be deleted in external * encoding, not UTF. */ { - DWORD result, size, maxSize; + DWORD result, size; Tcl_DString subkey; HKEY hKey; @@ -1180,23 +1202,17 @@ RecursiveDeleteKey( if (result != ERROR_SUCCESS) { return result; } - result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL, - &maxSize, NULL, NULL, NULL, NULL, NULL, NULL); - maxSize++; - if (result != ERROR_SUCCESS) { - return result; - } Tcl_DStringInit(&subkey); Tcl_DStringSetLength(&subkey, - (int) ((regWinProcs->useWide) ? maxSize * 2 : maxSize)); + (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH)); while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ - size = maxSize; + size = MAX_KEY_LENGTH; result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { @@ -1216,9 +1232,9 @@ RecursiveDeleteKey( * * 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. + * 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. @@ -1237,11 +1253,11 @@ SetValue( Tcl_Obj *dataObj, /* Data to be written. */ Tcl_Obj *typeObj) /* Type of data to be written. */ { - DWORD type, result; + int type; + DWORD result; HKEY key; int length; char *valueName; - Tcl_Obj *resultPtr; Tcl_DString nameBuf; if (typeObj == NULL) { @@ -1259,19 +1275,19 @@ SetValue( valueName = Tcl_GetStringFromObj(valueNameObj, &length); valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); - resultPtr = Tcl_GetObjResult(interp); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - DWORD value; - if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) { + int value; + + if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) { RegCloseKey(key); Tcl_DStringFree(&nameBuf); return TCL_ERROR; } - value = ConvertDWORD(type, value); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE*) &value, sizeof(DWORD)); + 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; @@ -1284,9 +1300,9 @@ SetValue( } /* - * 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. + * 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); @@ -1294,8 +1310,8 @@ SetValue( 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 + * 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. */ @@ -1305,16 +1321,16 @@ SetValue( Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE *) Tcl_DStringValue(&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; - char *data = Tcl_GetStringFromObj(dataObj, &length); + CONST char *data = Tcl_GetStringFromObj(dataObj, &length); - data = (char *) Tcl_WinUtfToTChar(data, length, &buf); + data = Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for Unicode. @@ -1325,8 +1341,8 @@ SetValue( } length = Tcl_DStringLength(&buf) + 1; - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - (BYTE*)data, (DWORD) length); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, + (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { BYTE *data; @@ -1335,14 +1351,17 @@ SetValue( * Store binary data in the registry. */ - data = Tcl_GetByteArrayFromObj(dataObj, &length); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type, - data, (DWORD) length); + 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_AppendToObj(resultPtr, "unable to set value: ", -1); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to set value: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -1354,9 +1373,8 @@ SetValue( * * BroadcastValue -- * - * This function broadcasts a WM_SETTINGCHANGE message to indicate - * to other programs that we have changed the contents of a registry - * value. + * 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. @@ -1371,13 +1389,13 @@ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj * CONST objv[]) /* Argument values. */ + Tcl_Obj *CONST objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; UINT timeout = 3000; int len; - char *str; + CONST char *str; Tcl_Obj *objPtr; if ((objc != 3) && (objc != 5)) { @@ -1387,7 +1405,8 @@ BroadcastValue( if (objc > 3) { str = Tcl_GetStringFromObj(objv[3], &len); - if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) { + if ((len < 2) || (*str != '-') + || strncmp(str, "-timeout", (size_t) len)) { Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); return TCL_ERROR; } @@ -1404,6 +1423,7 @@ BroadcastValue( /* * Use the ignore the result. */ + result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); @@ -1420,8 +1440,8 @@ BroadcastValue( * * AppendSystemError -- * - * This routine formats a Windows system error message and places - * it into the interpreter result. + * This routine formats a Windows system error message and places it into + * the interpreter result. * * Results: * None. @@ -1438,15 +1458,18 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - WCHAR *wMsgPtr; + 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 *) &wMsgPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr, 0, NULL); if (length == 0) { char *msgPtr; @@ -1483,6 +1506,7 @@ AppendSystemError( /* * Trim the trailing CR/LF from the system message. */ + if (msg[length-1] == '\n') { msg[--length] = 0; } @@ -1492,8 +1516,9 @@ AppendSystemError( } sprintf(id, "%ld", error); - Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL); + Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL); Tcl_AppendToObj(resultPtr, msg, length); + Tcl_SetObjResult(interp, resultPtr); if (length != 0) { Tcl_DStringFree(&ds); @@ -1505,8 +1530,8 @@ AppendSystemError( * * ConvertDWORD -- * - * This function determines whether a DWORD needs to be byte - * swapped, and returns the appropriately swapped value. + * This function determines whether a DWORD needs to be byte swapped, and + * returns the appropriately swapped value. * * Results: * Returns a converted DWORD. @@ -1529,6 +1554,14 @@ ConvertDWORD( * 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; + 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: + */ -- cgit v0.12