/****************************** Module Header ******************************* * * Module Name: colors.erx * * Change EPM''s standard 16-color palette for keyword hiliting. * * This file can be called outside of EPM. In that case EPMENV.CMD is required * in the dir of this file. * * The usage of WPS objects for color configuration as an additional layer * beside the cfg files requires additional functions to synchronize them. * Both scenarios are supported: Additional palette objects may be created or * changed and also cfg files may be changed, without simultaneously required * change of the palette objects by the user. Therefore an automatic * synchronization was added to manage that in most cases. * * At every call of this macro two arrays were created: * Cfg. names and colors from NEPMD.INI * Pal. names and colors from the palette objects * After that, the automatic synchronization between the config keys and the * palette objects is executed. * * Copyright (c) Netlabs EPM Distribution Project 2012 * * $Id: colors.erx 4405 2021-03-08 17:58:16Z aschn $ * * =========================================================================== * * This file is part of the Netlabs EPM Distribution package and is free * software. You can redistribute it and/or modify it under the terms of the * GNU General Public License as published by the Free Software * Foundation, in version 2 as it comes in the "COPYING" file of the * Netlabs EPM Distribution. This library is distributed in the hope that it * will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty * of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * General Public License for more details. * ****************************************************************************/ IF ADDRESS() <> 'EPM' THEN '@ECHO OFF' /* ----------------- Standard ERX initialization follows ----------------- */ SIGNAL ON HALT NAME Halt SIGNAL ON ERROR NAME Error SIGNAL ON SYNTAX NAME Error SIGNAL ON NOVALUE NAME Error SIGNAL ON FAILURE NAME Error SIGNAL ON NOTREADY NAME Error env = 'OS2ENVIRONMENT' TRUE = (1 = 1) FALSE = (0 = 1) CrLf = '0d0a'x Redirection = '>NUL 2>&1' PARSE SOURCE . . ThisFile GlobalVars = 'env TRUE FALSE Redirection ERROR. ThisFile ThisName' GlobalVars = GlobalVars 'ErrorQueueName ErrorMessage' /* Some OS/2 error codes */ ERROR.NO_ERROR = 0 ERROR.INVALID_FUNCTION = 1 ERROR.FILE_NOT_FOUND = 2 ERROR.PATH_NOT_FOUND = 3 ERROR.ACCESS_DENIED = 5 ERROR.NOT_ENOUGH_MEMORY = 8 ERROR.INVALID_FORMAT = 11 ERROR.INVALID_DATA = 13 ERROR.NO_MORE_FILES = 18 ERROR.WRITE_FAULT = 29 ERROR.READ_FAULT = 30 ERROR.SHARING_VIOLATION = 32 ERROR.GEN_FAILURE = 31 ERROR.INVALID_PARAMETER = 87 ERROR.ENVVAR_NOT_FOUND = 204 rc = ERROR.NO_ERROR ErrorQueueName = VALUE( 'NEPMD_RXQUEUE',, env) ErrorMessage = '' PARSE SOURCE . . ThisFile lp = LASTPOS( '\', ThisFile) ThisDir = LEFT( ThisFile, lp - 1) ThisName = SUBSTR( ThisFile, lp + 1) CALL RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs' CALL SysLoadFuncs /* ----------------- Standard ERX initialization ends -------------------- */ /* Extend the environment, if not already */ next = VALUE( 'NEPMD_NAME',, env) IF next = '' THEN 'CALL' ThisDir'\..\..\netlabs\bin\EPMENV' /* ------------- Configuration ---------------- */ RootDir = VALUE( 'NEPMD_ROOTDIR',, env) UserDir = VALUE( 'NEPMD_USERDIR',, env) NetlabsBinDir = RootDir'\netlabs\bin' UserBinDir = UserDir'\bin' WorkDir = UserBinDir /* Where palettes and ColorIni is located or will be created */ DestDllDir = UserDir'\dll' TmpDir = UserDir'\tmp' /* Better use a unique name in %TMP%? */ DllName = 'etke603.dll' Signature = 'GpiCreatePS failed' SaveFileExt = 'sav' Ini._Filename = UserDir'\bin\nepmd.ini' Ini._RegKeys = 'RegKeys' Ini._RegContainer = 'RegContainer' Ini._RegDefaults = 'RegDefaults' Ini._Install = 'Install' Ini._UserColorsNewlyImported = 'UserColorsNewlyImported' Key._MainPath = '\NEPMD\User\Colors\Highlighting' Key._Name = 'Name' DO 1 DefaultsCfg = UserBinDir'\defaults.cfg' IF FileExist( DefaultsCfg) THEN DO File._DefaultsCfg = DefaultsCfg LEAVE END DefaultsCfg = NetlabsBinDir'\defaults.cfg' IF FileExist( DefaultsCfg) THEN DO File._DefaultsCfg = DefaultsCfg LEAVE END END PalTitlePrefix = 'EPM color palette - ' /* previously used */ ObjectIdPrefix = 'EPM_PAL_' NameNotSpecified = '' /* The OS/2 color palette starts with the bottom line. Therefore the 8 top colors */ /* were exchanged with the 8 bottom colors. The index used here goes from 1 to 16 */ /* to make it easy for use with the words and wordpos functions. Note that the */ /* predefined values go from 0 to 15. In the docs LIGHT_GREY is called 'pale grey'. */ /* That is not defined. In NEPMD, the word 'gray' is used instead of 'GREY'. */ PalIndexList = , '9 10 11 12 13 14 15 16' ||, ' 1 2 3 4 5 6 7 8' ColorList = , 'black blue green cyan red magenta brown light_gray' ||, ' dark_gray light_blue light_green light_cyan light_red light_magenta yellow white' /* -------------------------------------------- */ GlobalVars = GlobalVars 'Ini. Key. Cfg. File. DefaultKey. Pal. Stem. fInit' GlobalVars = GlobalVars 'PalTitlePrefix ObjectIdPrefix NameNotSpecified' GlobalVars = GlobalVars 'PalIndexList ColorList' GlobalVars = GlobalVars 'WorkDir TmpDir DllName rc Lxlite Unlock' /* rc was made global to allow functions return other values */ CALL RxFuncAdd 'WPToolsLoadFuncs', 'WPTOOLS', 'WPToolsLoadFuncs' CALL WPToolsLoadFuncs /* Find tools */ Lxlite = FindTool( 'lxlite') Unlock = FindTool( 'unlock') DO 1 fInit = 0 /* Parse args */ PARSE ARG Args PARSE VAR Args Action Rest Action = TRANSLATE( Action) IF (Action = '') THEN DO rc = ERROR.INVALID_PARAMETER ErrorMessage = 'Error: No action specified. First parameter' ||, ' for 'TRANSLATE( ThisName)' is missing.' LEAVE END Arg2 = '' Arg3 = '' DO WHILE (Rest <> '') Rest = STRIP( Rest) IF (LEFT( Rest, 1) = '"') THEN PARSE VAR Rest '"'ThisArg'"' Rest ELSE PARSE VAR Rest ThisArg Rest SELECT WHEN Arg2 = '' THEN Arg2 = ThisArg WHEN Arg3 = '' THEN Arg3 = ThisArg OTHERWISE rc = ERROR.INVALID_PARAMETER ErrorMessage = 'Invalid parameter "'ThisArg'".' LEAVE END END IF rc <> ERROR.NO_ERROR THEN LEAVE /* Init stem vars */ DO c = 1 TO WORDS( ColorList) Cfg.c. = '' END Cfg._HexColors. = '' Cfg._NameFound. = '' Cfg._ColorsEqual. = '' /* n = 1 to Cfg._Name.0 = counter */ /* Name = Cfg._Name.n = group name */ /* g = Cfg._Group.n = group id */ Cfg._Name. = '' Cfg._Name.0 = 0 Cfg._Group. = '' Pal._HexColors. = '' Pal._NameFound. = '' Pal._ColorsEqual. = '' Pal._Name. = '' Pal._Name.0 = 0 /* Get all user keys */ CALL GetUserGroups /* Get all default keys */ /* This fills also the DefaultKey. array */ CALL GetDefaultGroups /* Get names for all available groups */ CALL GetGroupNames /* Add user and default hex colors to stem 'Cfg.' */ CALL BuildCfgArray /* Read colors of palette objects into stem 'Pal.' */ rc = ReadPalettes() /* Find new or changed palettes or new groups in config keys */ rc = ComparePalCfgKey() /* Sync palettes and config keys */ rc = SyncPalCfgKey() /* Execute Action */ SELECT /* Get list of palettes, separated by '|', for listbox */ WHEN ABBREV( Action, 'L') THEN DO ListBoxData = GetPalNameList() EXIT( ListBoxData) END /* Copy palette */ WHEN ABBREV( Action, 'C') THEN /* arg3 = new name */ CALL CopyPal Arg2, Arg3 /* Delete palette */ WHEN ABBREV( Action, 'D') THEN CALL DeletePal Arg2 /* Open palette */ WHEN ABBREV( Action, 'O') THEN CALL OpenPalObj Arg2 /* Select palette, patch DLL */ WHEN ABBREV( Action, 'S') THEN DO 1 /* Create tmp dir and change to work dir */ CALL SysMkDir WorkDir CALL SysMkDir TmpDir CALL SysMkDir DestDllDir CALL DIRECTORY WorkDir IF SUBSTR( WorkDir, 2, 1) = ':' THEN CALL DIRECTORY SUBSTR( WorkDir, 1, 2) /* Find original DLL in LIBPATH */ DllFullname = FindLibPath( DllName) IF DllFullname = '' THEN DO ErrorMessage = DllName 'not found in LIBPATH.' rc = ERROR.FILE_NOT_FOUND LEAVE END /* Create work and backup copies of DLL */ WorkDllFullName = TmpDir'\'DllName rc = BackupDll( DllFullname, SaveFileExt, WorkDllFullName) IF rc <> ERROR.NO_ERROR THEN LEAVE /* Destination dir for patched DLL */ DestDllFullName = DestDllDir'\'DllName PalName = Arg2 IF PalName = '' THEN DO rc = ERROR.INVALID_PARAMETER ErrorMessage = 'Missing palette name for "'Action'".' LEAVE END /* Get color string for DLL */ HexColors = GetHexColors( PalName) IF HexColors = '' THEN DO ErrorMessage = PalName 'not found in array. HexColors is empty.' rc = ERROR.INVALID_DATA LEAVE END DllColors = HexColorsToDllColors( HexColors) IF DllColors = '' THEN DO ErrorMessage = PalName 'not found in array. DllColors is empty.' rc = ERROR.INVALID_DATA LEAVE END /* Patch work DLL */ rc = PatchDll( DllFullName, WorkDllFullName, Signature, DllColors) IF rc <> ERROR.NO_ERROR THEN LEAVE /* Create and call an external CMD file. Replace previous DLL */ rc = ReplaceDll( DestDllFullName, WorkDllFullName, TmpDir, NetlabsBinDir) END OTHERWISE rc = ERROR.INVALID_PARAMETER ErrorMessage = 'Invalid parameter "'Action'".' END END /* ErrorMessage */ DO 1 IF ErrorMessage = '' THEN LEAVE /* Prepend 'Error 'rc ... if ErrorMessage doesn't contain the word 'Error' */ IF POS( 'ERROR', TRANSLATE( ErrorMessage)) = 0 THEN ErrorMessage = 'Error 'rc' running 'ThisFile': 'ErrorMessage CALL SayErrorMessage END EXIT( rc) /* ----------------------------------------------------------------------- */ GetUserGroups: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* Get user sub keys from RegContainer */ UserSubKeys = '' next = SysIni( Ini._Filename, Ini._RegContainer, Key._MainPath) next = STRIP( next, 'T', '00'x) IF next <> '' & next <> 'ERROR:' THEN UserSubKeys = next /* Add user groups to Cfg._Group. */ rest = UserSubKeys Sep = '00'x DO FOREVER PARSE VAR rest SubKey(Sep)rest IF SubKey = '' THEN LEAVE /* Check item for integer > 0 as group id */ IF VERIFY( SubKey, '0123456789') <> 0 THEN ITERATE IF SubKey = 0 THEN ITERATE /* Check if SubKey is present in Cfg._Group. */ fFound = 0 DO n = 1 TO Cfg._Name.0 IF SubKey = Cfg._Group.n THEN DO fFound = 1 LEAVE END END IF fFound = 0 THEN DO /* Add SubKey to Cfg._Group. */ n = Cfg._Name.0 + 1 Cfg._Group.n = SubKey Cfg._Name.0 = n END END RETURN( rc) /* ----------------------------------------------------------------------- */ GetDefaultGroups: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* Get all default keys */ DefaultKey. = '' DefaultKey.0 = 0 next = SysIni( Ini._Filename, Ini._RegDefaults, 'ALL:', 'DefaultKey.') IF next = 'ERROR:' THEN fInit = 1 IF fInit THEN next = TextIniToStem( File._DefaultsCfg, 'ALL:', 'ALL:', 'DefaultKey.') SearchKey = Key._MainPath'\' SearchLen = LENGTH( SearchKey) DO k = 1 TO DefaultKey.0 /* Find keys that start with SearchKey */ IF LEFT( DefaultKey.k, SearchLen) = SearchKey THEN DO /* Get reamaining key string */ SubKey = SUBSTR( DefaultKey.k, SearchLen + 1) /* Get first path segment */ PARSE VAR SubKey SubKey'\'. PARSE VAR SubKey SubKey '=' . /* Check item for integer > 0 as group id */ IF VERIFY( SubKey, '0123456789') <> 0 THEN ITERATE IF SubKey = 0 THEN ITERATE /* Check if SubKey is present in Cfg._Group. */ fFound = 0 DO n = 1 TO Cfg._Name.0 IF SubKey = Cfg._Group.n THEN DO fFound = 1 LEAVE END END IF fFound = 0 THEN DO /* Add SubKey to Cfg._Group. */ n = Cfg._Name.0 + 1 Cfg._Group.n = SubKey Cfg._Name.0 = n END END END RETURN( rc) /* ----------------------------------------------------------------------- */ GetGroupNames: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* Get names for all available groups */ DO n = 1 TO Cfg._Name.0 /* Use saved group id to query names */ g = Cfg._Group.n /* Query user key */ next = SysIni( Ini._Filename, Ini._RegKeys, Key._MainPath'\'g'\'Key._Name) next = STRIP( next, 'T', '00'x) IF next <> '' & next <> 'ERROR:' THEN DO Cfg._Name.n = next ITERATE END /* Query default key */ IF fInit THEN DO next = FindTextIniVal( 'DefaultKey.', Key._MainPath'\'g'\'Key._Name) IF \(next = '') THEN DO Cfg._Name.n = next ITERATE END END ELSE DO next = SysIni( Ini._Filename, Ini._RegDefaults, Key._MainPath'\'g'\'Key._Name) next = STRIP( next, 'T', '00'x) IF next <> '' & next <> 'ERROR:' THEN DO Cfg._Name.n = next ITERATE END END Cfg._Name.n = NameNotSpecified END RETURN( rc) /* ----------------------------------------------------------------------- */ GetPalNameList: PROCEDURE EXPOSE (GlobalVars) ListBoxData = '' /* Create lists of palette names */ DO n = 1 TO Cfg._Name.0 ListBoxData = ListBoxData'|'Cfg._Name.n END RETURN( ListBoxData) /* ----------------------------------------------------------------------- */ BuildCfgArray: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* If a user color value wasn't specified, take that color value */ /* from the 'NEPMD' color group, which has the id 101. */ DefaultGroup = 101 DO n = 1 to Cfg._Name.0 g = Cfg._Group.n /* Init stem var */ Cfg.n. = '' /* Add user colors to Cfg.g. */ DO c = 1 TO WORDS( ColorList) SubKey = WORD( ColorList, c) Cfg.c.n = '0 0 0' /* Default color value, if unset */ DO 1 /* Query key */ next = SysIni( Ini._Filename, Ini._RegKeys, Key._MainPath'\'g'\'SubKey) next = STRIP( next, 'T', '00'x) IF next <> '' & next <> 'ERROR:' THEN LEAVE /* User color key missing, try to get default key for this color from DefaultKeys */ IF fInit THEN DO next = FindTextIniVal( 'DefaultKey.', Key._MainPath'\'g'\'SubKey) IF \(next = '') THEN LEAVE END ELSE DO next = SysIni( Ini._Filename, Ini._RegDefaults, Key._MainPath'\'g'\'SubKey) next = STRIP( next, 'T', '00'x) IF next <> '' & next <> 'ERROR:' THEN LEAVE END /* Color key missing, get default key for this color from 'NEPMD' colors */ IF fInit THEN DO next = FindTextIniVal( 'DefaultKey.', Key._MainPath'\'DefaultGroup'\'SubKey) IF \(next = '') THEN LEAVE END ELSE DO next = SysIni( Ini._Filename, Ini._RegDefaults, Key._MainPath'\'DefaultGroup'\'SubKey) next = STRIP( next, 'T', '00'x) IF next <> '' & next <> 'ERROR:' THEN LEAVE END END IF next <> '' & next <> 'ERROR:' THEN DO /* Add next to Cfg.c.n */ Cfg.c.n = next END END HexColors = '' idx = 0 RGBhex. = '' RGBhex.0 = 0 DO c = 1 to WORDS( ColorList) ColorName = WORD( ColorList, c) IF ColorName = '' THEN ITERATE ColorVal = Cfg.c.n red = WORD( ColorVal, 1) green = WORD( ColorVal, 2) blue = WORD( ColorVal, 3) redhex = RIGHT( D2X( red), 2, '0') greenhex = RIGHT( D2X( green), 2, '0') bluehex = RIGHT( D2X( blue), 2, '0') idx = WORDPOS( c, PalIndexList) /* idx = 1...16 */ RGBhex.idx = '0x'redhex''greenhex''bluehex RGBhex.0 = RGBhex.0 + 1 END DO idx = 1 TO RGBhex.0 IF idx = 1 THEN HexColors = RGBhex.idx ELSE HexColors = HexColors','RGBhex.idx END CALL VALUE 'Cfg._HexColors.'n, HexColors END RETURN( rc) /* ----------------------------------------------------------------------- */ GetHexColors: PROCEDURE EXPOSE (GlobalVars) PARSE ARG PalName rc = ERROR.NO_ERROR HexColors = '' DO 1 DO n = 1 TO Cfg._Name.0 Name = Cfg._Name.n IF PalName = Cfg._Name.n THEN DO HexColors = VALUE( 'Cfg._HexColors.'n) LEAVE END END IF HexColors = '' THEN DO rc = ERROR.INVALID_DATA LEAVE END END RETURN( HexColors) /* ----------------------------------------------------------------------- */ HexColorsToDllColors: PROCEDURE EXPOSE (GlobalVars) PARSE ARG HexColors c = 0 idx = 0 BGRchar. = '' DllColors = '' Rest = HexColors DO WHILE Rest <> '' IF LEFT( Rest, 2) <> '0x' THEN LEAVE PARSE VAR Rest '0x'Next','Rest PARSE VAR Next 1 redhex 3 greenhex 5 bluehex /* Re-arrange colors according to PalIndexList */ c = c + 1 idx = WORD( PalIndexList, c) BGRchar.idx = X2C( bluehex)''X2C( greenhex)''X2C( redhex)'00'x END DO idx = 1 to WORDS( PalIndexList) DllColors = DllColors''BGRchar.idx END RETURN( DllColors) /* ----------------------------------------------------------------------- */ ReadPalettes: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* Get PalNames and colors from all palette objects */ rcx = WPToolsFolderContent( WorkDir, 'AbstractObj.') p = 0 Pal. = '' Pal._Name.0 = 0 DO a = 1 TO AbstractObj.0 Class = '' rcx = WPToolsQueryObject( AbstractObj.a, 'Class', 'Title', 'Setup', 'Location') IF Class <> 'WPColorPalette' THEN ITERATE /* Ensure that maybe just changed palette object has written its data */ PARSE VALUE Setup WITH ';OBJECTID='ObjectId';' . IF ObjectId <> '' THEN DO AsyncFlag = 0 rcx = SysSaveObject( ObjectId, AsyncFlag) END rcx = WPToolsQueryObject( AbstractObj.a, 'Class', 'Title', 'Setup', 'Location') PARSE VALUE Setup WITH ';COLORS='HexColors';' . /* Strip previously used PalTitlePrefix, if present */ PARSE VALUE Title WITH (PalTitlePrefix) PalName IF PalName = '' THEN PARSE VALUE Title WITH PalName IF HexColors = '' | PalName = '' THEN ITERATE p = p + 1 Pal._Name.0 = p Pal._Name.p = PalName Pal._HexColors.p = HexColors END RETURN( rc) /* ----------------------------------------------------------------------- */ CopyPal: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR PARSE ARG PalName, NewPalName IF NewPalName = '' THEN NewPalName = NameNotSpecified HexColors = '' DO 1 /* Search PalName */ nFound = 0 DO n = 1 TO Cfg._Name.0 IF Cfg._Name.n = PalName THEN DO nFound = n LEAVE END END IF nFound = 0 THEN DO rc = ERROR.FILE_NOT_FOUND LEAVE END /* Find last used group id for user colors */ LastGroup = 0 LastUserNumber = 0 DO n = Cfg._Name.0 TO 1 BY -1 IF Cfg._Group.n > 100 THEN ITERATE IF Cfg._Group.n <> '' THEN DO LastGroup = Cfg._Group.n LastUserNumber = n LEAVE END END /* Use next free group id */ g = LastGroup + 1 n = LastUserNumber + 1 /* Move default groups to the bottom to make room after the last user group */ rc = MoveCfgNumber( 1, n, Cfg._Name.0) /* Copy Cfg. and write config keys */ DO c = 1 TO WORDS( ColorList) SubKey = WORD( ColorList, c) ColorVal = Cfg.c.nFound Cfg.c.n = ColorVal rc = WriteConfigKey( Key._MainPath'\'g'\'SubKey, ColorVal) END /* Set HexColors to Cfg. */ HexColors = Cfg._HexColors.nFound Cfg._HexColors.n = HexColors /* Set name to Cfg. and write config key */ Cfg._Name.n = NewPalName rc = WriteConfigKey( Key._MainPath'\'g'\'Key._Name, NewPalName) /* Create new palette or overwrite it */ /* This may omitted here, because of automatic sync on next query. */ /* Sync executes this again, probably because it takes some time */ /* to write the object data to OS2.INI and the list is queried */ /* immediately after this again. */ rc = CreatePalObj( NewPalName, HexColors) /* Set Pal. array (not required, because comparism is only made ast startup) */ p = Pal._Name.0 + 1 Pal._Name.0 = p Pal._Name.p = NewPalName Pal._HexColors.p = HexColors END RETURN( rc) /* ----------------------------------------------------------------------- */ DeletePal: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR PARSE ARG PalName HexColors = '' DO 1 /* Search PalName */ nFound = 0 DO n = 1 TO Cfg._Name.0 IF Cfg._Name.n = PalName THEN DO nFound = n LEAVE END END IF nFound = 0 THEN DO rc = ERROR.FILE_NOT_FOUND LEAVE END n = nFound g = Cfg._Group.n /* Don't delete default color palettes */ IF g > 100 THEN ITERATE /* Delete color config keys */ DO c = 1 TO WORDS( ColorList) SubKey = WORD( ColorList, c) rc = DeleteConfigKey( Key._MainPath'\'g'\'SubKey) END /* Delete config key */ rc = DeleteConfigKey( Key._MainPath'\'g'\'Key._Name) /* Delete palette */ rc = DeletePalObj( PalName) /* Move all following stems */ rc = MoveCfgNumber( -1, n, Cfg._Name.0) /* Set Pal. array (not required, because comprism is only made ast startup) */ Lastp = Pal._Name.0 Newp = Lastp DO p = 1 TO Pal._Name.0 IF p > Lastp THEN LEAVE /* Search PalName */ Foundp = 0 IF Pal._Name.p = PalName THEN Foundp = p IF Foundp > 0 THEN /* Move all following stems */ DO Newp = p - 1 Pal._Name.Newp = Pal._Name.p Pal._HexColors.Newp = Pal._HexColors.p Lastp = Lastp - 1 END END Pal._Name.0 = Newp END RETURN( rc) /* ----------------------------------------------------------------------- */ CreatePalObj: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR PARSE ARG PalName, HexColors PalTitle = PalName ObjectId = '<'ObjectIdPrefix''TRANSLATE( PalName)'>' UpdateReplaceFail = 'R' PalClass = 'WPColorPalette' PalSetup = , 'XCELLCOUNT=8;' ||, 'YCELLCOUNT=2;' ||, 'XCELLWIDTH=48;' ||, 'YCELLHEIGHT=51;' ||, 'XCELLGAP=9;' ||, 'YCELLGAP=13;' ||, 'COLORS='HexColors';' ||, 'TITLE='PalTitle';' ||, 'NOPRINT=YES;' ||, 'HIDEBUTTON=DEFAULT;' ||, 'MINWIN=DEFAULT;' ||, 'CCVIEW=DEFAULT;' ||, 'DEFAULTVIEW=DEFAULT;' ||, 'OBJECTID='ObjectId';' rcx = SysCreateObject( PalClass, PalTitle, WorkDir, PalSetup, UpdateReplaceFail) AsyncFlag = 0 rcx = SysSaveObject( ObjectId, AsyncFlag) RETURN( rc) /* ----------------------------------------------------------------------- */ DeletePalObj: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR PARSE ARG PalName PalTitle = PalTitlePrefix''PalName ObjectId = '<'ObjectIdPrefix''TRANSLATE( PalName)'>' rcx = SysDestroyObject( ObjectId) RETURN( rc) /* ----------------------------------------------------------------------- */ OpenPalObj: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR PARSE ARG PalName PalTitle = PalTitlePrefix''PalName ObjectId = '<'ObjectIdPrefix''TRANSLATE( PalName)'>' rcx = SysSetObjectData( ObjectId, 'OPEN=DEFAULT;') rc = (rcx = 1) RETURN( rc) /* ----------------------------------------------------------------------- */ WriteConfigKey: PROCEDURE EXPOSE (GlobalVars) PARSE ARG KeyPath, KeyVal rc = ERROR.NO_ERROR DO 1 /* 1) Write to RegKeys */ next = SysIni( Ini._Filename, Ini._RegKeys, KeyPath, KeyVal'00'x) IF (next = 'ERROR:') THEN DO rc = ERROR.WRITE_FAULT LEAVE END /* 2) Write RegContainer */ ThisKeyPath = '' /* Set ThisContainer to first segment */ PARSE VALUE KeyPath WITH '\'ThisContainer'\'rest DO FOREVER ThisKeyPath = ThisKeyPath'\'ThisContainer /* The last entry for ThisKeyPath in RegContainer is the parent path of KeyPath */ IF LENGTH( ThisKeyPath) >= LENGTH( KeyPath) THEN LEAVE Startp = LENGTH( ThisKeyPath) + 1 p = POS( '\', KeyPath, Startp + 1) /* + 1 to ignore the leading backslash */ IF p == 0 THEN p = LENGTH( KeyPath) + 1 IF Startp > LENGTH( KeyPath) THEN DO ThisContainer = '' LEAVE END ELSE ThisContainer = SUBSTR( KeyPath, Startp + 1, p - Startp - 1) /* Query RegContainer for ThisKeyPath */ next = SysIni( Ini._Filename, Ini._RegContainer, ThisKeyPath) next = STRIP( next, 'T', '00'x) IF (next = 'ERROR:') THEN Containers = '' ELSE Containers = next /* Search ThisContainer in Containers */ cp = POS( '00'x''ThisContainer'00'x, '00'x''Containers'00'x) IF cp > 0 THEN ITERATE /* Append ThisContainer to Containers */ IF Containers = '' THEN rest = ThisContainer ELSE rest = Containers'00'x''ThisContainer /* Convert Containers to stem for sorting */ i = 0 Stem. = '' Stem.0 = 0 Sep = '00'x DO FOREVER PARSE VAR rest SubKey(Sep)rest IF SubKey = '' THEN LEAVE i = i + 1 Stem.i = SubKey Stem.0 = i /* Sort Container stem */ CALL SortStem /* Reconvert Containers to zero-separated list */ NewContainers = '' DO i = 1 TO Stem.0 IF NewContainers == '' THEN NewContainers = Stem.i ELSE NewContainers = NewContainers'00'x''Stem.i END /* Write to RegContainer */ next = SysIni( Ini._Filename, Ini._RegContainer, ThisKeyPath, NewContainers'00'x) IF (next = 'ERROR:') THEN DO rc = ERROR.WRITE_FAULT LEAVE END END END RETURN( rc) /* ----------------------------------------------------------------------- */ DeleteConfigKey: PROCEDURE EXPOSE (GlobalVars) PARSE ARG KeyPath rc = ERROR.NO_ERROR DO 1 /* 1) Delete from RegKeys */ next = SysIni( Ini._Filename, Ini._RegKeys, KeyPath, 'DELETE:') /* No error from here, to continue with RegContainer even if RegKey doesn't exist */ /* 2) Delete from RegContainer */ /* Query all RegKeys for to check if a RegContainer key can be deleted */ TestKeys. = '' AllKeysResult = SysIni( Ini._Filename, Ini._RegKeys, 'ALL:', 'TestKeys.') NextKeyPath = KeyPath /* Remove ThisContainer from ParentPath value */ DO FOREVER ThisKeyPath = NextKeyPath /* Query RegContainer for ParentPath */ lp = LASTPOS( '\', ThisKeyPath) IF lp <= 1 THEN LEAVE ThisContainer = SUBSTR( ThisKeyPath, lp + 1) ParentPath = SUBSTR( ThisKeyPath, 1, lp - 1) NextKeyPath = ParentPath next = SysIni( Ini._Filename, Ini._RegContainer, ParentPath) next = STRIP( next, 'T', '00'x) IF (next = 'ERROR:') THEN ITERATE Containers = next /* Search ThisContainer in Containers */ cp = POS( '00'x''ThisContainer'00'x, '00'x''Containers'00'x) IF cp == 0 THEN ITERATE /* Find ThisKeyPath'\*' keys to check if ThisContainer can be deleted */ IF (AllKeysResult = 'ERROR:') THEN ITERATE fThisContainerUsed = 0 DO k = 1 TO TestKeys.0 IF LEFT( TestKeys.k, LENGTH( ThisKeyPath'\')) <> ThisKeyPath'\' THEN ITERATE ELSE DO fThisContainerUsed = 1 LEAVE END END IF fThisContainerUsed = 1 THEN ITERATE /* Delete ThisContainer from NewContainers */ NewContainers = SUBSTR( Containers'00'x, 1, cp - 1) ||, SUBSTR( Containers'00'x, cp + LENGTH( ThisContainer) + 1) NewContainers = STRIP( NewContainers, 'T', '00'x) IF NewContainers == '' THEN DO /* Delete RegContainer key */ next = SysIni( Ini._Filename, Ini._RegContainer, ParentPath, 'DELETE:') IF (next = 'ERROR:') THEN DO rc = ERROR.WRITE_FAULT LEAVE END END ELSE DO /* Write to RegContainer */ next = SysIni( Ini._Filename, Ini._RegContainer, ParentPath, NewContainers'00'x) IF (next = 'ERROR:') THEN DO rc = ERROR.WRITE_FAULT LEAVE END END END END RETURN( rc) /* ----------------------------------------------------------------------- */ /* SysStemSort isn't contained in older REXXUTIL.DLL versions. */ SortStem: PROCEDURE EXPOSE (GlobalVars) CALL SortStem2 1, Stem.0 RETURN /* ----------------------------------------------------------------------- */ /* Mainly from html2ipf.cmd by Andrew Zabolotny. */ SortStem2: PROCEDURE EXPOSE (GlobalVars) ARG iFirst, iLast iLeft = iFirst iRight = iLast iMiddle = (iLeft + iRight) % 2 DO UNTIL iLeft > iRight DO WHILE Stem.iLeft < Stem.iMiddle iLeft = iLeft + 1 END DO WHILE Stem.iRight > Stem.iMiddle iRight = iRight - 1 END IF iLeft <= iRight THEN DO tmp = Stem.iLeft Stem.iLeft = Stem.iRight Stem.iRight = tmp iLeft = iLeft + 1 iRight = iRight - 1 END END IF iFirst < iRight THEN CALL SortStem2 iFirst, iRight IF iLeft < iLast THEN CALL SortStem2 iLeft, iLast RETURN /* ----------------------------------------------------------------------- */ ComparePalCfgKey: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* Compare Pal. with Cfg. */ DO p = 1 TO Pal._Name.0 PalName = Pal._Name.p HexColors = Pal._HexColors.p Pal._NameFound.p = 0 Pal._ColorsEqual.p = 0 DO n = 1 TO Cfg._Name.0 /* Compare Name */ IF Pal._NameFound.p == 0 THEN DO IF PalName = Cfg._Name.n THEN Pal._NameFound.p = n END /* Compare HexColors */ IF Pal._ColorsEqual.p == 0 THEN DO IF HexColors = Cfg._HexColors.n THEN Pal._ColorsEqual.p = n END END END /* Compare Cfg. with Pal. */ DO n = 1 TO Cfg._Name.0 PalName = Cfg._Name.n HexColors = Cfg._HexColors.n Cfg._NameFound.n = 0 Cfg._ColorsEqual.n = 0 DO p = 1 TO Pal._Name.0 /* Compare Name */ IF Cfg._NameFound.n == 0 THEN DO IF PalName = Pal._Name.p THEN Cfg._NameFound.n = p END /* Compare HexColors */ IF Cfg._ColorsEqual.n == 0 THEN DO IF HexColors = Pal._HexColors.p THEN Cfg._ColorsEqual.n = p END END END RETURN( rc) /* ----------------------------------------------------------------------- */ SyncPalCfgKey: PROCEDURE EXPOSE (GlobalVars) rc = ERROR.NO_ERROR /* Query UserColorsNewlyImported */ fUserColorsNewlyImported = 0 next = SysIni( Ini._Filename, Ini._Install, Ini._UserColorsNewlyImported) next = STRIP( next, 'T', '00'x) IF (next = 'ERROR:') THEN /* Don't report error here */ NOP ELSE fUserColorsNewlyImported = (next = 1) /* Reset UserColorsNewlyImported */ next = SysIni( Ini._Filename, Ini._Install, Ini._UserColorsNewlyImported, 0'00'x) IF (next = 'ERROR:') THEN /* Don't report error here */ NOP /* Find last used group id for user colors */ LastGroup = 0 LastUserNumber = 0 DO n = Cfg._Name.0 TO 1 BY -1 IF Cfg._Group.n > 100 THEN ITERATE IF Cfg._Group.n <> '' THEN DO LastGroup = Cfg._Group.n LastUserNumber = n LEAVE END END DO p = 1 TO Pal._Name.0 PalName = Pal._Name.p HexColors = Pal._HexColors.p /* Create missing Cfg. group and config key or overwrite with colors from palette */ SELECT WHEN Pal._NameFound.p == 0 THEN DO /* Use next free group id */ g = LastGroup + 1 n = LastUserNumber + 1 /* Move default groups to the bottom to make room after the last user group */ rc = MoveCfgNumber( 1, n, Cfg._Name.0) /* Set colors to Cfg. and write config keys */ rc = HexColorsToRegKeys( n, g, PalName, HexColors) /* Set name to Cfg. and write config key */ Cfg._Name.n = PalName rc = WriteConfigKey( Key._MainPath'\'g'\'Key._Name, PalName) /* Reset comparism result for source (just cosmetic) */ Pal._NameFound.p = n Pal._ColorsEqual.p = n /* Reset comparism result for destination (just cosmetic) */ Cfg._NameFound.n = p Cfg._ColorsEqual.n = p END WHEN Pal._ColorsEqual.p == 0 THEN DO /* Get n from comparism */ n = Pal._NameFound.p /* Get group id */ g = Cfg._Group.n /* For default colors, always sync from Cfg. to Pal. */ IF g > 100 THEN ITERATE /* After importing user.cfg, sync from Cfg. to Pal. */ IF fUserColorsNewlyImported THEN ITERATE /* Set colors to Cfg. and write config keys */ rc = HexColorsToRegKeys( n, g, PalName, HexColors) /* Reset comparism result for source (just cosmetic) */ Pal._ColorsEqual.p = n /* Reset comparism result for destination */ Cfg._ColorsEqual.n = p END OTHERWISE NOP END END /* Last used palette number */ LastPal = Pal._Name.0 DO n = 1 TO Cfg._Name.0 PalName = Cfg._Name.n HexColors = Cfg._HexColors.n /* Create missing palette or overwrite with colors from RegKey */ SELECT WHEN Cfg._NameFound.n == 0 THEN DO /* Use next free pal number */ LastPal = LastPal + 1 /* Advance pal counter */ p = LastPal Pal._Name.0 = p /* Set colors to Pal. and write palette objects */ rc = HexColorsToPalette( p, PalName, HexColors) /* Reset comparism result for source (just cosmetic) */ Cfg._NameFound.n = p Cfg._ColorsEqual.n = p /* Reset comparism result for destination (just cosmetic) */ Pal._NameFound.p = n Pal._ColorsEqual.p = n END WHEN Cfg._ColorsEqual.n == 0 THEN DO /* Get p from comparism */ p = Cfg._NameFound.n /* Set colors to Pal. and write palette objects */ rc = HexColorsToPalette( p, PalName, HexColors) /* Reset comparism result for source (just cosmetic) */ Cfg._ColorsEqual.n = p /* Reset comparism result for destination */ Pal._ColorsEqual.p = n END OTHERWISE NOP END END RETURN( rc) /* ----------------------------------------------------------------------- */ MoveCfgNumber: PROCEDURE EXPOSE (GlobalVars) PARSE ARG nAmount, nStartMove, nEndMove rc = ERROR.NO_ERROR /* Add an item */ IF nAmount > 0 THEN DO nFirst = nEndMove nLast = nStartMove nStep = -1 END /* Remove an item */ ELSE DO nFirst = nStartMove + 1 nLast = nEndMove nStep = 1 END DO n = nFirst TO nLast BY nStep nNew = n + nAmount /* Ensure that counter Cfg._Name.0 is not overridden */ /* when nFirst or nLast were set wrong */ IF nNew = 0 THEN ITERATE /* Move existing vars from n to nNew */ DO c = 1 TO WORDS( ColorList) Cfg.c.nNew = Cfg.c.n END Cfg._HexColors.nNew = Cfg._HexColors.n Cfg._Name.nNew = Cfg._Name.n Cfg._Group.nNew = Cfg._Group.n Cfg._NameFound.nNew = Cfg._NameFound.n Cfg._ColorsEqual.nNew = Cfg._ColorsEqual.n END IF nAmount < 0 THEN DO n = Cfg._Name.0 + nAmount TO Cfg._Name.0 /* Reset unused vars */ DO c = 1 TO WORDS( ColorList) Cfg.c.n = '' END Cfg._HexColors.n = '' Cfg._Name.n = '' Cfg._Group.n = '' Cfg._NameFound.n = '' Cfg._ColorsEqual.n = '' END Cfg._Name.0 = Cfg._Name.0 + nAmount RETURN( rc) /* ----------------------------------------------------------------------- */ MovePalNumber: PROCEDURE EXPOSE (GlobalVars) PARSE ARG pAmount, pStartMove, pEndMove rc = ERROR.NO_ERROR IF pAmount > 0 THEN DO pFirst = pEndMove pLast = pStartMove pStep = -1 END ELSE DO pFirst = pStartMove pLast = pEndMove pStep = 1 END DO p = pFirst TO pLast BY pStep pNew = p + pAmount Pal._Name.pNew = Pal._Name.p Pal._HexColors.pNew = Pal._HexColors.p Pal._NameFound.pNew = Pal._NameFound.p Pal._ColorsEqual.pNew = Pal._ColorsEqual.p END IF pAmount < 0 THEN DO p = Pal._Name.0 + pAmount TO Pal._Name.0 /* Reset unused vars */ Pal._Name.p = '' Pal._HexColors.p = '' Pal._NameFound.p = '' Pal._ColorsEqual.p = '' END Pal._Name.0 = Pal._Name.0 + pAmount RETURN( rc) /* ----------------------------------------------------------------------- */ HexColorsToRegKeys: PROCEDURE EXPOSE (GlobalVars) PARSE ARG n, g, PalName, HexColors rc = ERROR.NO_ERROR /* Copy Cfg. and write config keys */ rest = HexColors c = 0 ColorValues. = '' DO WHILE rest <> '' PARSE VALUE rest WITH '0x'next','rest PARSE VALUE next WITH redhex +2 greenhex +2 bluehex IF redhex = '' | greenhex = '' | bluehex = '' THEN DO rc = ERROR.INVALID_DATA LEAVE END red = X2D( redhex) green = X2D( greenhex) blue = X2D( bluehex) c = c + 1 ColorVal = RIGHT( red, 3)' 'RIGHT( green, 3)' 'RIGHT( blue, 3) Cfg.c.n = ColorVal SubKey = WORD( ColorList, c) rc = WriteConfigKey( Key._MainPath'\'g'\'SubKey, ColorVal) END /* Set HexColors to Cfg. */ Cfg._HexColors.n = HexColors RETURN( rc) /* ----------------------------------------------------------------------- */ HexColorsToPalette: PROCEDURE EXPOSE (GlobalVars) PARSE ARG p, PalName, HexColors rc = ERROR.NO_ERROR /* Create new palette or overwrite it */ rc = CreatePalObj( PalName, HexColors) /* Set HexColors to Pal. */ Pal._HexColors.p = HexColors RETURN( rc) /* ----------------------------------------------------------------------- */ BackupDll: PROCEDURE EXPOSE (GlobalVars) PARSE ARG DllFullname, SaveFileExt, WorkDllFullName rc = ERROR.NO_ERROR DO 1 /* Create work copy */ 'COPY' DllFullName WorkDllFullName IF rc <> 0 THEN DO ErrorMessage 'Backup: "'DllFullName'" not copied to work dir "'WorkDir'". rc = 'rc'.' LEAVE END /* Assemble filename for backup file: */ /* In dir of original file, with extension .sav instead of .dll */ lp1 = LASTPOS( '\', DllFullName) DllDir = SUBSTR( DllFullName, 1, MAX( lp1 - 1, 0)) lp2 = LASTPOS( '.', DllFullName) DllBaseName = SUBSTR( DllFullName, lp1 + 1, MAX( lp2 - lp1 - 1, 0)) BackupName = DllBaseName'.'SaveFileExt BackupFile = DllDir'\'BackupName IF FileExist( BackupFile) THEN NOP ELSE DO /* Create backup */ 'COPY' DllFullName BackupFile IF rc <> 0 THEN DO ErrorMessage = 'Backup: "'DllFullName'" not copied to "'BackupName'". rc = 'rc'. ' LEAVE END DO s = 1 TO 3 IF FileExist( BackupFile) THEN LEAVE CALL SysSleep 0.5 END END CALL SysSetObjectData BackupFile, 'TITLE='BackupName';' END RETURN( rc) /* ----------------------------------------------------------------------- */ /* Finds a Dll in libpath or extended libpath. Returns empty if not found. */ FindLibPath: PROCEDURE EXPOSE (GlobalVars) PARSE ARG DllName DllFullName = '' BootDrive = GetBootDrive() LibpathDirs = GetTextIniValue( BootDrive'\config.sys', '', 'LIBPATH') fFunctionFound = 0 IF \RxFuncQuery( 'SYSQUERYEXTLIBPATH') THEN fFunctionFound = 1 IF fFunctionFound = 1 THEN BeginLibpathDirs = SysQueryExtLIBPATH( 'B') ELSE DO 'CALL RXQUEUE /CLEAR' 'SET BEGINLIBPATH|RXQUEUE /FIFO' PARSE PULL BeginLibpathDirs PARSE VALUE BeginLibpathDirs WITH . '=' BeginLibpathDirs END IF BeginLibpathDirs = '(null)' THEN BeginLibpathDirs = '' IF fFunctionFound = 1 THEN EndLibpathDirs = SysQueryExtLIBPATH( 'E') ELSE DO 'CALL RXQUEUE /CLEAR' 'SET ENDLIBPATH|RXQUEUE /FIFO' PARSE PULL EndLibpathDirs PARSE VALUE EndLibpathDirs WITH . '=' EndLibpathDirs END IF EndLibpathDirs = '(null)' THEN EndLibpathDirs = '' IF \(fFunctionFound = 1) THEN 'CALL RXQUEUE /CLEAR' IF BeginLibpathDirs > '' THEN LibpathDirs = STRIP( BeginLibpathDirs, 'T', ';')';'LibpathDirs IF EndLibpathDirs > '' THEN LibpathDirs = STRIP( LibpathDirs, 'T', ';')';'EndLibpathDirs rest = LibpathDirs DO WHILE rest <> '' PARSE VALUE rest WITH Dir';'rest next = Dir'\'DllName IF FileExist( next) THEN DO DllFullName = next LEAVE END END RETURN( DllFullName) /* ----------------------------------------------------------------------- */ GetBootDrive: PROCEDURE EXPOSE (GlobalVars) IF \RxFuncQuery( 'SysBootDrive') THEN BootDrive = SysBootDrive() ELSE PARSE UPPER VALUE VALUE( 'PATH',, env) WITH ':\OS2\SYSTEM' -1 BootDrive +2 RETURN( BootDrive) /* ----------------------------------------------------------------------- */ /* This is used here for CONFIG.SYS parsing */ GetTextIniValue: PROCEDURE EXPOSE (GlobalVars) PARSE ARG File, ApplicationList, Key Entry = '' IF ApplicationList = '' THEN ApplicationList = 'ALL:' Application = '' next = STREAM( File, 'C', 'OPEN READ') DO WHILE CHARS( File) > 0 line = LINEIN( File) SELECT WHEN LEFT( line, 1) = ';' THEN NOP WHEN STRIP( line) = '' THEN NOP WHEN LEFT( line, 1) = '[' THEN DO p2 = POS( ']', line) IF p2 > 0 THEN DO nextApplication = SUBSTR( line, 2, p2 - 2) IF WORDPOS( nextApplication, ApplicationList) > 0 | ApplicationList = 'ALL:' THEN Application = nextApplication ELSE Application = '' /* nextApplication is other, reset Application */ END END OTHERWISE PARSE VALUE line WITH nextKey '=' nextEntry /* it must be a 'Key = Entry' line */ nextKey = STRIP( nextKey) nextEntry = STRIP( nextEntry) IF ApplicationList <> 'ALL:' & Application = '' THEN ITERATE IF nextKey = '' THEN ITERATE IF nextKey = Key THEN DO Entry = nextEntry LEAVE /* key found */ END END END rc = STREAM( File, 'C', 'CLOSE') RETURN( Entry) /* ----------------------------------------------------------------------- */ /* Syntax: */ /* rc = TextIniToStem( File, ApplicationList, Key, Stem) */ /* Adds key = value lines of a text ini file to a specified stem var. The */ /* search can be reduced to a list of ini applications or to a key. If no */ /* Application list is specified, 'ALL:' applications are listed. If no */ /* key is specified, 'ALL:' keys are listed. The number of items is */ /* written to Stem''0. */ /* Different from SysIni for OS/2 ini files, TextIniToStem always lists */ /* entire lines. Theerefore, in most cases, that list has to be parsed */ /* to key and value pairs. */ /* Example: */ /* rcx = TextIniToStem( 'defaults.cfg', 'ALL:', 'ALL:', 'DefaultKey.') */ /* DO n = 1 TO DefaultKey.0 */ /* SAY DefaultKey.n */ /* END */ /* This is used here for DEFAULTS.CFG parsing */ TextIniToStem: /* Adding the value of StemVar to the expose list is not possible. Therefore this function must be global. */ rc = ERROR.NO_ERROR PARSE ARG File, ApplicationList, Key, StemVar Entry = '' IF ApplicationList = '' THEN ApplicationList = 'ALL:' Application = '' IF Key = '' THEN Key = 'ALL:' IF RIGHT( StemVar, 1) <> '.' THEN StemVar = StemVar'.' CALL VALUE StemVar, '' CALL VALUE StemVar''0, 0 next = STREAM( File, 'C', 'OPEN READ') DO WHILE CHARS( File) > 0 line = LINEIN( File) SELECT WHEN LEFT( line, 1) = ';' THEN NOP WHEN STRIP( line) = '' THEN NOP WHEN LEFT( line, 1) = '[' THEN DO p2 = POS( ']', line) IF p2 > 0 THEN DO nextApplication = SUBSTR( line, 2, p2 - 2) IF WORDPOS( nextApplication, ApplicationList) > 0 | ApplicationList = 'ALL:' THEN Application = nextApplication ELSE Application = '' /* nextApplication is other, reset Application */ END END OTHERWISE PARSE VALUE line WITH nextKey '=' nextEntry /* it must be a 'Key = Entry' line */ nextKey = STRIP( nextKey) nextEntry = STRIP( nextEntry) IF ApplicationList <> 'ALL:' & Application = '' THEN ITERATE IF nextKey = '' THEN ITERATE IF Key = 'ALL:' | nextKey = Key THEN DO s = VALUE( StemVar''0) + 1 CALL VALUE StemVar''0, s CALL VALUE StemVar''s, nextKey'='nextEntry END END END rc = STREAM( File, 'C', 'CLOSE') RETURN( rc) /* ----------------------------------------------------------------------- */ /* Requires a previous call to TextIniToStem. Returns Val for a specified */ /* Key. */ FindTextIniVal: PROCEDURE EXPOSE (GlobalVars) Val = '' PARSE ARG StemVar, Key IF RIGHT( StemVar, 1) <> '.' THEN StemVar = StemVar'.' DO s = 1 TO VALUE( StemVar''0) ThisLine = VALUE( StemVar''s) PARSE VALUE ThisLine WITH ThisKey '=' ThisVal ThisKey = STRIP( ThisKey) ThisVal = STRIP( ThisVal) IF ThisKey = Key THEN DO Val = ThisVal LEAVE END END RETURN( Val) /* ----------------------------------------------------------------------- */ PatchDll: PROCEDURE EXPOSE (GlobalVars) PARSE ARG DllFullName, WorkDllFullName, Signature, DllColors rc = ERROR.NO_ERROR DO 1 WorkDll = WorkDllFullName /* First, check for errors, because LxLite doesn't return a useful rc */ IF \FileExist( WorkDll) THEN DO rc = ERROR.FILE_NOT_FOUND ErrorMessage = 'WorkDll "'WorkDll'" doesn''t exist, rc = 'rc'.' LEAVE END IF STREAM( WorkDll, 'C', 'OPEN') <> 'READY:' THEN DO rc = ERROR.ACCESS_DENIED ErrorMessage = 'WorkDll "'WorkDll'" can''t be opened, rc = 'rc'.' LEAVE END ELSE CALL STREAM WorkDll, 'C', 'CLOSE' /* Unpack DLL with LxLite */ LxLite '/YDL /YUR /x' WorkDll IF rc <> 0 THEN DO /* LxLite 1.3.3 always returns rc = 0. With 'CALL' it returns rc = 0. */ /* LxLite 1.3.9 always returns rc = 5. With 'CALL' it returns rc = 99. */ /* ErrorMessage = 'lxLite returned on expansion of "'WorkDll'" with rc = 'rc'.' LEAVE */ rc = ERROR.NO_ERROR END IF ADDRESS() = 'EPM' THEN 'SayHint Patching the DLL...' /* Read DLL content */ IF STREAM( WorkDll, 'C', 'OPEN') <> 'READY:' THEN DO rc = ERROR.ACCESS_DENIED LEAVE END FileLen = CHARS( WorkDll) FileContent = CHARIN( WorkDll,, FileLen) CALL STREAM WorkDll, 'C', 'CLOSE' /* Change DLL content */ p2 = POS( Signature, FileContent) IF p2 = 0 THEN DO ErrorMessage = 'Signature "'Signature'" not found in 'WorkDllFullName'.' rc = ERROR.INVALID_DATA LEAVE END p1 = p2 - 64 /* Get the 64 chars before the signature */ FileContent = OVERLAY( DllColors, FileContent, p1) /* Write changed DLL content */ IF STREAM( WorkDll, 'C', 'OPEN') <> 'READY:' THEN DO rc = ERROR.ACCESS_DENIED LEAVE END rcx = FileDelete( WorkDll) CALL CHAROUT WorkDll, FileContent CALL STREAM WorkDll, 'C', 'CLOSE' /* Pack DLL with LxLite */ LxLite '/YDL /YUR' WorkDll IF rc <> 0 THEN DO /* LxLite 1.3.3 always returns rc = 0. With 'CALL' it returns rc = 0. */ /* LxLite 1.3.9 always returns rc = 5. With 'CALL' it returns rc = 99. */ /* ErrorMessage = 'lxLite returned on compression of "'WorkDll'" with rc = 'rc'.' LEAVE */ rc = ERROR.NO_ERROR END END RETURN( rc) /* ----------------------------------------------------------------------- */ ReplaceDll: PROCEDURE EXPOSE (GlobalVars) PARSE ARG DestDllFullName, WorkDllFullName, TmpDir, NetlabsBinDir rc = ERROR.NO_ERROR DO 1 DestDll = DestDllFullName WorkDll = WorkDllFullName lp = LASTPOS( '\', DestDllFullName) IF lp > 0 THEN DestDir = LEFT( DestDllFullName, lp - 1) ELSE DestDir = '' lp = LASTPOS( '\', WorkDllFullName) IF lp > 0 THEN WorkDir = LEFT( WorkDllFullName, lp - 1) ELSE WorkDir = '' IF ADDRESS() = 'EPM' THEN DO 'SayHint Replacing the DLL and restarting...' 'CloseOtherWin' call SysSleep 1 'CheckOnlyEpmWindow' 'RingCheckModify' 'SaveRing' END /* Write temp. CMD file and execute it */ TmpFile = TmpDir'\copydll.cmd' IF FileExist( TmpFile) THEN rcx = SysFileDelete( TmpFile) CALL LINEOUT TmpFile, "/* COPYDLL.CMD - NEPMD project */" CALL LINEOUT TmpFile, "/* Copy patched DLL after EPM was closed */" CALL LINEOUT TmpFile, "CALL RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'" CALL LINEOUT TmpFile, "CALL SysLoadFuncs" CALL LINEOUT TmpFile, "'@ECHO OFF'" /* If it's the only window, it works also without unlock. The */ /* disadvantage would be an additional delay of 1 s after EPM */ /* was closed. */ CALL LINEOUT TmpFile, "Unlock = '"Unlock"'" CALL LINEOUT TmpFile, "Unlock '"DestDll"'" CALL LINEOUT TmpFile, "'COPY" WorkDll DestDll"'" CALL LINEOUT TmpFile, "IF rc <> 0 THEN" CALL LINEOUT TmpFile, "DO" CALL LINEOUT TmpFile, " 'PAUSE'" CALL LINEOUT TmpFile, " EXIT( rc)" CALL LINEOUT TmpFile, "END" CALL LINEOUT TmpFile, "CALL SysSleep 2" /* Required for restart, better use pstat */ CALL LINEOUT TmpFile, "'CD "NetlabsBinDir"'" IF ADDRESS() = 'EPM' THEN CALL LINEOUT TmpFile, "'CALL EPMRESUME'" CALL LINEOUT TmpFile, "IF rc <> 0 THEN" CALL LINEOUT TmpFile, "DO" CALL LINEOUT TmpFile, " 'PAUSE'" CALL LINEOUT TmpFile, " EXIT( rc)" CALL LINEOUT TmpFile, "END" CALL LINEOUT TmpFile, "'DEL "WorkDll"'" CALL LINEOUT TmpFile, "'DEL "TmpFile"'" CALL LINEOUT TmpFile, "'RMDIR "WorkDir"'" CALL LINEOUT TmpFile, "EXIT( 0)" rcx = STREAM( TmpFile, 'c', 'close') Cmd = 'START /c /min' TmpFile ''Cmd IF rc <> 0 THEN DO ErrorMessage = '"'Cmd'" returned rc = 'rc'.' LEAVE END IF ADDRESS() = 'EPM' THEN 'postme Close' END RETURN( rc) /* ----------------------------------------------------------------------- */ FindTool: PROCEDURE EXPOSE (GlobalVars) Exe = '' Parameters = '' WorkingDir = '' DefaultCmd = '' ValidKeywords = 'Exe Parameters WorkingDir DefaultCmd' FoundExe = '' fWpsEntry = 0 do once = 1 to 1 Tool = Lower( ARG(1)) /* Allow for a space- or a semicolon-separated keyword list. */ /* Keywords are case-sensitive (camel-case). */ Keywords = STRIP( TRANSLATE( ARG(2), ' ', ';')) /* Check keywords */ UnknownKeywords = '' DO w = 1 TO WORDS( Keywords) next = WORD( Keywords, w) IF WORDPOS( next, ValidKeywords) = 0 THEN UnknownKeywords = strip( UnknownKeywords next) END IF UnknownKeywords <> '' THEN DO ErrorMessage = 'FindTool: Unknown keyword(s) "'UnknownKeywords'" specified.' rc = ERROR.INVALID_PARAMETER RETURN '' END /* Check if key \ToolBaseName is defined */ /* This key can be used as a reference to another exe */ KeyPath = '\NEPMD\User\Tools\'Tool'\ToolBaseName' next = SysIni( Ini._Filename, Ini._RegKeys, KeyPath) IF next = 'ERROR:' THEN CfgToolBaseName = '' ELSE CfgToolBaseName = Lower( STRIP( next, 'T', '00'x)) /* If not, take Tool instead */ IF CfgToolBaseName <> '' THEN ToolBaseName = CfgToolBaseName ELSE ToolBaseName = Tool /* Strip extension */ p2 = LASTPOS( '.exe', ToolBaseName) IF p2 > 1 THEN ToolBaseName = SUBSTR( ToolBaseName, 1, p2 - 1) /* Refer to defined config key */ IF WORDPOS( ToolBaseName,'md5sum md5suml md5') THEN ToolBaseName = 'md5' /* Read entries from ini */ KeyPath = '\NEPMD\User\Tools\'ToolBaseName next = SysIni( Ini._Filename, Ini._RegKeys, KeyPath'\Exe') IF next = 'ERROR:' THEN Exe = '' ELSE Exe = STRIP( next, 'T', '00'x) next = SysIni( Ini._Filename, Ini._RegKeys, Keypath'\Parameters') IF next = 'ERROR:' THEN Parameters = '' ELSE Parameters = STRIP( next, 'T', '00'x) next = SysIni( Ini._Filename, Ini._RegKeys, KeyPath'\WorkingDir') IF next = 'ERROR:' THEN WorkingDir = '' ELSE WorkingDir = STRIP( next, 'T', '00'x) next= SysIni( Ini._Filename, Ini._RegKeys, KeyPath'\DefaultCmd') IF next = 'ERROR:' THEN DefaultCmd = '' ELSE DefaultCmd = STRIP( next, 'T', '00'x) /* Allow for specifying env vars in value */ Exe = ResolveEnvVars( Exe) WorkingDir = ResolveEnvVars( WorkingDir) /* Use fallback value if config key isn't defined */ IF Exe = '' THEN Exe = ToolBaseName'.exe' /* Handle WPS and fully qualified filenames */ IF TRANSLATE( Exe) = 'WPS' THEN DO fWpsEntry = 1 leave END IF POS( ':\', Exe) | LEFT( Exe, 2) = '\\' THEN DO IF FileExist( Exe) THEN DO FoundExe = Exe LEAVE END END ToolList = Exe PathEnvVarList = 'PATH EPMTOOLSPATH' FoundExe = '' DO w = 1 TO WORDS( PathEnvVarList) CurPath = WORD( PathEnvVarList, w) Rest = ToolList DO FOREVER IF Rest = '' THEN LEAVE PARSE VALUE Rest WITH FSpec';'Rest FoundExe = SysSearchPath( CurPath, FSpec) IF FoundExe <> '' THEN LEAVE END IF FoundExe <> '' THEN LEAVE END END IF fWpsEntry THEN DO SELECT WHEN Tool = 'mail' THEN DO Exe = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultMailExe') Parameters = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultMailParameters') WorkingDir = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultMailWorkingDir') END WHEN Tool = 'news' THEN DO Exe = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultNewsExe') Parameters = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultNewsParameters') WorkingDir = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultNewsWorkingDir') END WHEN Tool = 'ftp' THEN DO Exe = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultFTPExe') Parameters = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultFTPParameters') WorkingDir = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultFTPWorkingDir') END WHEN Tool = 'irc' THEN DO Exe = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultIRCExe') Parameters = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultIRCParameters') WorkingDir = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultIRCWorkingDir') END END IF Tool = 'browser' | Exe = '' THEN DO Exe = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultBrowserExe') Parameters = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultParameters') WorkingDir = SysIni( 'USER', 'WPURLDEFAULTSETTINGS', 'DefaultWorkingDir') END FoundExe = Exe END RetString = '' IF Keywords = '' THEN RetString = FoundExe ELSE DO k = 1 to WORDS( Keywords) Keyword = WORD( Keywords, k) Val = '' SELECT WHEN Keyword = 'Exe' THEN Val = FoundExe WHEN Keyword = 'Parameters' THEN Val = Parameters WHEN Keyword = 'WorkingDir' THEN Val = WorkingDir WHEN Keyword = 'DefaultCmd' THEN Val = DefaultCmd END RetString = RetString''Keyword'='Val';' END RETURN RetString /* ----------------------------------------------------------------------- */ /* Resolves environment variables in a string. Keeps %...% string if env */ /* var isn't set. Additionally ?: is replaced with the boot drive. Returns */ /* converted string. */ /* To convert also '=', the proc parse_filename( filename) should be used. */ /* It calls this proc as well. */ ResolveEnvVars: PROCEDURE EXPOSE (GlobalVars) Spec = ARG(1) startp = 1 DO FOREVER p1 = POS( '%', Spec, startp) IF p1 = 0 THEN LEAVE startp = p1 + 1 p2 = POS( '%', Spec, startp) IF p2 = 0 THEN LEAVE LeftPart = SUBSTR( Spec, 1, p1 - 1) EnvVarName = SUBSTR( Spec, p1 + 1, p2 - p1 - 1) RightPart = SUBSTR( Spec, p2 + 1) EnvVarValue = Get_Env( EnvVarName) /* Handle unset vars: keep %... or %...% string */ IF EnvVarValue = '' THEN ITERATE /* Value exists, replace %...% string and move startp */ startp = LENGTH( LeftPart) + LENGTH( EnvVarValue) + 1 Spec = LeftPart''EnvVarValue''RightPart END /* Replace ?: with bootdrive */ DO WHILE POS( '?:', Spec) > 0 PARSE VALUE Spec WITH LeftPart'?:'RightPart BootDrive = GetBootDrive() Spec = LeftPart''BootDrive''RightPart END RETURN Spec /* ----------------------------------------------------------------------- */ Lower: PROCEDURE EXPOSE (GlobalVars) LoTable = 'abcdefghijklmnopqrstuvwxyz„”' UpTable = 'ABCDEFGHIJKLMNOPQRSTUVWXYZŽ™š' PARSE ARG String RETURN( TRANSLATE( String, LoTable, UpTable)) /* ----------------------------------------------------------------------- */ FileExist: PROCEDURE EXPOSE (GlobalVars) PARSE ARG Filename IF FileName = '' THEN RETURN( 0) ELSE RETURN( STREAM( Filename, 'C', 'QUERY EXISTS') <> '') /* ----------------------------------------------------------------------- */ FileDelete: PROCEDURE EXPOSE (GlobalVars) PARSE ARG Filename PauseSecs = 0.4 /* Older REXXUTIL DLLs take that as 1 */ rc = SysFileDelete( Filename) DO s = 1 TO 3 IF STREAM( Filename, 'C', 'QUERY EXISTS') = '' THEN LEAVE CALL SysSleep PauseSecs END RETURN( rc) /* ----------------------------------------------------------------------- */ FileRename: PROCEDURE EXPOSE (GlobalVars) PARSE ARG Filename, NewFilename IF POS( ' ', Filename) > 0 THEN Filename = '"'Filename'"' IF POS( ' ', NewFilename) > 0 THEN NewFilename = '"'NewFilename'"' IF ADDRESS() = 'EPM' THEN /* Rename is an EPM command */ 'quietshell rename' Filename NewFilename ELSE 'rename' Filename NewFilename RETURN( rc) /* --------------------- Standard ERX macros follow ---------------------- */ /* ----------------------------------------------------------------------- */ SayText: PROCEDURE EXPOSE (GlobalVars) PARSE ARG Message SELECT WHEN ADDRESS() = 'EPM' THEN 'sayerror' Message OTHERWISE SAY Message END RETURN( '') /* ----------------------------------------------------------------------- */ /* For PmPrintf output, use CALL SayDegug '...' When being called from an */ /* environment outside of EPM, the message text is processed by a SAY */ /* statement instead. */ SayDebug: PROCEDURE EXPOSE (GlobalVars) PARSE ARG Message SELECT WHEN ADDRESS() = 'EPM' THEN 'dprintf' Message OTHERWISE SAY Message END RETURN( '') /* ----------------------------------------------------------------------- */ SayErrorMessage: PROCEDURE EXPOSE (GlobalVars) SELECT WHEN (ErrorMessage = '') THEN NOP /* Called by frame program: insert error */ /* message into private queue */ WHEN (ErrorQueueName <> '') THEN DO rcx = RXQUEUE( 'SET', ErrorQueueName) PUSH ErrorMessage END /* Called directly */ WHEN ADDRESS() = 'EPM' THEN DO 'sayerror' ErrorMessage rcx = RxMessageBox( ErrorMessage, TRANSLATE( ThisName),, 'OK', 'ERROR') END /* Called directly */ OTHERWISE DO SAY ErrorMessage 'PAUSE' END END RETURN( '') /* ----------------------------------------------------------------------- */ Halt: ErrorMessage = 'Interrupted by user.' CALL SayErrorMessage EXIT( ERROR.GEN_FAILURE) /* ----------------------------------------------------------------------- */ /* Give a standard REXX error message and jump to the error line */ Error: /* sigl must be saved to not get overwritten by SayErrorMessage call */ ErrorLine = sigl /* As an extension to the standard REXX error messages, */ /* the error condition will be appended to the error text. */ ConditionText = 'Condition: 'CONDITION( 'C') ConditionDescription = CONDITION( 'D') IF ConditionDescription <> '' THEN ConditionText = ConditionText', Reason: 'ConditionDescription ErrText = ERRORTEXT( rc) IF ErrText = '' THEN ErrText = ConditionText ELSE ErrText = ErrText', 'ConditionText ErrorMessage = 'REX'RIGHT( rc, 4, 0)': Error 'rc' running 'ThisFile',' ||, ' line 'sigl': 'ErrText CALL SayErrorMessage IF ADDRESS() = 'EPM' THEN "e "ThisFile" 'postme "ErrorLine"'" /* Ensure that rc <> 0 is returned */ IF rc = 0 THEN rc = ERROR.GEN_FAILURE EXIT( rc)