Chip 2002 March/Chip_2002-03_cd1.bin/sharewar/Slunec/app/ppww32.exe/REGIT.REX

OS/2 REXX Batch file | 2001-12-08 | 17.7 KB | 650 lines

/*
 * Generator   : PPWIZARD version 01.340
 *             : FREE tool for Windows, OS/2, DOS and UNIX by Dennis Bareis ([e-mail])
 *             : http://www.labyrinth.net.au/~dbareis/ppwizard.htm
 * Time        : Saturday, 8 Dec 2001 4:54:35pm
 * Input File  : C:\DBAREIS\Projects\Win32\RegIt\REGIT.x
 * Output File : C:\DBAREIS\Projects\Win32\RegIt\out\REGIT.rex
 */

if arg(1)="!CheckSyntax!" then exit(21924)

/*
*  REGIT: Makes associations (including Right-Click on objects) easier
*
*  Note ppwizard makes a good front end for this and gives you
*  more programability, conditional inclusion as well as file
*  inclusion.
*
*  Get the latest version from:
*
*      http://www.labyrinth.net.au/~dbareis/index.htm
*
*/
/* Need to add:
*
* add standard trap handlers etc
*
* Add debug code/mode
*
*/
LineNum = ''
PgmVersion  = '01.342'
ShownHeader = 'N'
trace off
OPTIONS 'NOEXT_COMMANDS_AS_FUNCS'
call MakeSureRequiredDllsAreAvailable
VarStart  = '$['
VarEnd    = ']'
VarStartL = length(VarStart)
VarEndL   = length(VarEnd)
IncludeLvl            = 1
LineNum.IncludeLvl    = 0
signal on NOVALUE name RexxTrapUninitializedVariable
signal on SYNTAX  name RexxTrapSyntaxError
/*
* REPLSTR.XH Version 99.134 By Dennis Bareis
*            http://www.labyrinth.net.au/~dbareis/index.htm ([e-mail])
*/
ReplaceCount = 0
signal EndREPLSTR

ReplaceString:
parse arg rs?TheString, rs?ChangeFrom
rs?FoundPosn = pos(rs?ChangeFrom, rs?TheString)
if  rs?FoundPosn = 0 then
return(rs?TheString)
rs?ChangeTo = arg(3)
rs?ChangeFromLength = length(rs?ChangeFrom)
rs?LeftPart         = ''
do  until rs?FoundPosn = 0
rs?LeftPart      = rs?LeftPart || left(rs?TheString, rs?FoundPosn-1) || rs?ChangeTo
rs?TheString     = substr(rs?TheString, rs?FoundPosn+rs?ChangeFromLength)
ReplaceCount = ReplaceCount + 1
rs?FoundPosn = pos(rs?ChangeFrom, rs?TheString)
end
return(rs?LeftPart || rs?TheString)

EndREPLSTR:
RitFile  = strip(arg(1))
RitFileF = stream(RitFile, 'c', 'query exists')
if RitFileF <> '' then
RitFile = RitFileF
else
do
RitFileE = RitFile || '.rit'
RitFileF = stream(RitFileE, 'c', 'query exists')
if  RitFileF <> '' then
RitFile = RitFileF
else
do
call ShowSyntax
Die('The ASSOCIATE file "' || RitFile || '" does not exist!')
end
end
Colon2     = ';' || ';'
EofChar    = '1A'x
LineBuffer = ''
WithinRexx = ''
InFile.IncludeLvl     = RitFile
CloseRc    = stream(InFile.IncludeLvl, 'c', 'close')
do while IncludeLvl >= 1 | LineBuffer <> ''
if  LineBuffer <> '' then
do
CurrentLine = LineBuffer
LineBuffer  = ''
end
else
do
if  lines(InFile.IncludeLvl) = 0 then
do
CloseRc    = stream(InFile.IncludeLvl, 'c', 'close')
IncludeLvl = IncludeLvl - 1
iterate
end
CurrentLine = strip(linein(InFile.IncludeLvl))
LineNum.IncludeLvl     = LineNum.IncludeLvl + 1
end
ScriptLine = CurrentLine
CurrentLine = strip(translate(CurrentLine, ' ', EofChar))
if  CurrentLine = '' then
iterate
if  left(CurrentLine, 1) = ';' then
iterate
InLinePos = lastpos(Colon2, CurrentLine)
if  InLinePos <> 0 then
CurrentLine = strip(left(CurrentLine, InLinePos-1))
parse var CurrentLine Word1 .
Word1 = translate(Word1)
if  Word1 <> 'IF' then
CurrentLine =  ExpandVariables(CurrentLine)
if  WithinRexx <> '' then
do
if  CurrentLine = '}' then
do
call ExecuteRexx RexxBlock
WithinRexx = ''
end
else
do
if  RexxBlock  <> '' then
RexxBlock = RexxBlock || '0A'x
RexxBlock = RexxBlock || CurrentLine
end
iterate
end
parse var CurrentLine Word1 AfterWord1Ws
Word1      = translate(Word1)
AfterWord1 = strip(AfterWord1Ws)
select
when translate(CurrentLine) = 'EOF' then
leave
when CurrentLine = '{' then
do
RexxBlock  = ''
WithinRexx = LineNum.IncludeLvl
end
when Word1 = 'VERSION' then
do
if  FixVersion(AfterWord1) > FixVersion(PgmVersion) then
Die('This script requires REGIT.REX to be at least version "' || AfterWord1 || '" but it is "' || PgmVersion || '".')
end
when Word1 = 'SAY' then
say strip(AfterWord1Ws, 'T')
when Word1 = 'PATH' | Word1 = 'PATHEXT' then
call HandlePathTypeRegEnvVar Word1
when Word1 = 'PATHTYPE' then
do
parse var AfterWord1 Word1 AfterWord1Ws
AfterWord1 = strip(AfterWord1Ws)
call HandlePathTypeRegEnvVar Word1
end
when Word1 = 'ENVVAR' then
call HandleEnvironmentVariable
when Word1 = 'REQUIRED' then
call RequiredFile(AfterWord1)
when Word1 = 'REXX' then
do
call ExecuteRexx AfterWord1
end
when Word1 = 'IF' then
do
LookFor     = ' THEN '
AfterWord1U = translate(AfterWord1)
ThenPos     = pos(LookFor, AfterWord1U)
if  ThenPos = 0 then
Die('"THEN" missing')
IfResult = 0
IfTest = 'IfResult = ( ' || strip(left(AfterWord1, ThenPos-1)) || ' )'
call ExecuteRexx IfTest
if  IfResult = 1 then
LineBuffer = strip(substr(AfterWord1, ThenPos+length(LookFor)))
end
when Word1 = 'DEFINE' then
do
parse var AfterWord1 VarName '=' VarContents
Alias = 'VAR_' || c2x(strip(VarName))
call value Alias, VarContents
end
when Word1 = 'INCLUDE' then
do
parse var AfterWord1 '"' FileParm '"' .
FileParmFull = stream(FileParm, 'c', 'query exists')
if  FileParmFull = '' then
do
Die('Could not find the include file "' || FileParm || '"')
end
IncludeLvl            = IncludeLvl + 1
LineNum.IncludeLvl    = 0
InFile.IncludeLvl     = FileParmFull
end
when Word1 = 'ASSOC' then
do
parse var AfterWord1 AssExtn '=' AssName
AssExtn = strip(AssExtn)
AssName = strip(AssName)
if  AssName = '' then
do
hRoot = w32RegOpenKey("CLASSES_ROOT")
if  hRoot <> 0 then
call w32RegDeleteKey hRoot, AssExtn
end
else
do
hAss = w32RegCreateKey('CLASSES_ROOT', AssExtn)
call w32RegSetValue hAss, '', 'REG_SZ', AssName
end
end
when Word1 = 'ASSOCMIME' then
do
parse var AfterWord1 AssExtn '=' AssMimeType
AssExtn     = strip(AssExtn)
AssMimeType = strip(AssMimeType)
if  AssMimeType = '' then
do
hExtn = w32RegOpenKey("CLASSES_ROOT", AssExtn)
if  hExtn <> 0 then
call w32RegDeleteKey hExtn, 'Content Type'
Die('ASSOCMIME does not yet support deletion')
end
else
do
hAss = w32RegOpenKey('CLASSES_ROOT', AssExtn)
call w32RegSetValue hAss, 'Content Type', 'REG_SZ', AssMimeType
end
end
when Word1 = 'FTYPE' then
do
parse var AfterWord1 AssName '/' AssOpenTitle '/' AssCommand
AssName      = strip(AssName)
AssOpenTitle = strip(AssOpenTitle)
if  AssCommand = '' then
do
hRoot = w32RegOpenKey("CLASSES_ROOT")
if  hRoot <> 0 then
call w32RegUnloadKey hRoot, AssName
Die('FTYPE does not yet support deletion')
end
else
do
hAss   = w32RegCreateKey('CLASSES_ROOT', AssName)
hShell = w32RegCreateKey(hAss,   'Shell')
hOpen  = w32RegCreateKey(hShell, 'Open')
hCmd   = w32RegCreateKey(hOpen,  'Command')
call w32RegSetValue hOpen, '', 'REG_SZ', AssOpenTitle
call w32RegSetValue hCmd,  '', 'REG_SZ', AssCommand
end
end
when Word1 = 'FTYPEICON' then
do
parse var AfterWord1 AssName '/' AssIcon
AssName = strip(AssName)
AssIcon = strip(AssIcon)
if  AssIcon = '' then
do
hRoot = w32RegOpenKey("CLASSES_ROOT")
if  hRoot <> 0 then
call w32RegDeleteKey hRoot, AssName || '\DefaultIcon'
end
else
do
hAss   = w32RegCreateKey('CLASSES_ROOT', AssName)
hIcon  = w32RegCreateKey(hAss,   'DefaultIcon')
call w32RegSetValue hIcon, '', 'REG_SZ', AssIcon
end
end
when Word1 = 'FTYPEDESC' then
do
parse var AfterWord1 AssName '/' AssDescription
AssName        = strip(AssName)
AssDescription = strip(AssDescription)
hAss = w32RegCreateKey('CLASSES_ROOT', AssName)
call w32RegSetValue hAss, '', 'REG_SZ', AssDescription
end
when Word1 = 'RCLICK' then
do
parse var AfterWord1 AssName '/' AssTitle '/' AssCommand
if  AssCommand = '' then
Die('Command to execute missing')
AssTitle = strip(AssTitle)
if  left(AssTitle, 1) <> '(' then
AssAlias = MakeAlias(AssTitle)
else
do
parse var AssTitle '(' AssAlias ')' AssTitle
AssAlias = strip(AssAlias)
AssTitle = strip(AssTitle)
end
hAss   = w32RegCreateKey('CLASSES_ROOT', AssName)
hShell = w32RegCreateKey(hAss, 'Shell')
hTitle = w32RegCreateKey(hShell, AssAlias)
hCmd   = w32RegCreateKey(hTitle, 'Command')
call w32RegSetValue hTitle, '', 'REG_SZ', AssTitle
call w32RegSetValue hCmd, '', 'REG_SZ', AssCommand
end
when left(CurrentLine, 1) = '(' then
do
parse var CurrentLine '(' Test4Ok ')' WinCmd
if  WinCmd = '' then
Die('Missing operating system command')
say 'Executing: ' || WinCmd
address system WinCmd
if  Test4Ok <> '' then
do
CmdRc = Rc
interpret 'TestOk = ' || Test4Ok
if  TestOk <> 1 then
Die('Command failed with Return code of ' || CmdRc)
end
end
otherwise
do
if  left(CurrentLine, 1) <> '#' then
Die('Command unknown: ' || CurrentLine)
else
do
say 'You may need to run this through ppwizard...'
Die('Command unknown: ' || CurrentLine)
end
end
end
end
if WithinRexx <> '' then
Die('Incomplete rexx block found, block started on line ' || WithinRexx)
exit(0)

FixVersion:
parse value strip(arg(1)) with VerYY '.' VerDDD
if  translate(VerYY) = '2K' then
VerYY = '00'
return(VerYY || '.' || VerDDD)

HandleEnvironmentVariable:
parse var AfterWord1 ChangeLevel '/' VarName '/' VarContents
ChangeLevel = translate(strip(ChangeLevel))
VarName = strip(VarName)
if  VarName = '' then
Die('No environment variable specified!')
select
when ChangeLevel = 'SYSTEM' then
hEnv = w32RegOpenKey('LOCAL_MACHINE', 'System\CurrentControlSet\Control\Session Manager\Environment')
when ChangeLevel = 'USER' then
hEnv = w32RegCreateKey('CURRENT_USER', 'Environment')
otherwise
Die('Unknown update level of "' || ChangeLevel || '"')
end
Failed = w32RegSetValue(hEnv, VarName, 'REG_SZ', VarContents)
if  Failed then
Die('Failed updating "' || ChangeLevel || '" registry for "' || VarName || '"')
return

HandlePathTypeRegEnvVar:
RegEnvVar = arg(1)
if  RegEnvVar = 'PATHEXT' then
RegAdding = 'extension'
else
RegAdding = 'directory'
parse var AfterWord1 ChangeLevel '/' BeingAdded '/' Positioning
ChangeLevel = translate(ChangeLevel)
if  ChangeLevel <> 'USER' & ChangeLevel <> 'SYSTEM' & ChangeLevel <> 'SYSTEM?' then
Die('Change level of "' || ChangeLevel || '" unknown expected "SYSTEM" or "USER"')
if  BeingAdded = '' then
Die('Missing ' || RegAdding || ' on "' || RegEnvVar || '" command')
if  RegEnvVar = 'PATHEXT' then
do
if  left(BeingAdded, 1) <> '.' then
Die('The ' || RegAdding || ' of "' || BeingAdded || '" does not start with a dot')
end
if  Positioning <> '' then
do
Positioning1 = left(Positioning, 1)
if  Positioning1 <> '<' & Positioning1 <> '>' then
Die('The positioning command "' || Positioning || '" does not start with "<" or ">"')
if  length(Positioning) <> 1 then
Die('Sorry currently only support "<" or ">" for positioning')
end
hSystem     = w32RegOpenKey('LOCAL_MACHINE', 'System\CurrentControlSet\Control\Session Manager\Environment')
SystemValue = w32RegQueryValue(hSystem, RegEnvVar)
if  SystemValue = '' then
do
if  RegEnvVar = 'PATHEXT' then
SystemValue = GetEnv(RegEnvVar)
if  SystemValue = '' then
Die('"' || RegEnvVar || '" not found in system''s configuration!')
end
if  ChangeLevel <> 'USER' then
do
NewSystemValue = Add2PathLikeVariable(SystemValue, Positioning, BeingAdded)
Failed = w32RegSetValue(hSystem, RegEnvVar, 'REG_SZ', NewSystemValue)
if  Failed then
Die('Failed updating system registry for "' || RegEnvVar || '"')
if  ChangeLevel = 'SYSTEM' then
return
end
UserVersionExists = 'N'
if  ChangeLevel = 'SYSTEM' then
PathExt = SystemValue
else
do
hUser = w32RegOpenKey('CURRENT_USER', 'Environment')
if  hUser = 0 then
UserValue = SystemValue
else
do
UserValue = w32RegQueryValue(hUser, RegEnvVar)
if  UserValue = '' then
UserValue = SystemValue
else
UserVersionExists = 'Y'
end
end
if  UserVersionExists = 'N' & ChangeLevel = 'SYSTEM?' then
return
UserValue = Add2PathLikeVariable(UserValue, Positioning, BeingAdded)
Failed = w32RegSetValue(hUser, RegEnvVar, 'REG_SZ', UserValue)
if  Failed then
Die('Failed updating registry for "' || RegEnvVar || '"')
return

Add2PathLikeVariable: procedure expose LineNum ScriptLine
parse arg UserValue, Positioning, BeingAdded
UserValue    = translate(UserValue) || ';'
BeingAdded   = translate(BeingAdded)
Positioning1 = left(Positioning, 1)
ExtPos  = pos(BeingAdded || ';', UserValue)
if  ExtPos <> 0 then
do
UserValue = left(UserValue, ExtPos-1) || substr(UserValue, ExtPos + length(BeingAdded)+1)
end
if  Positioning <> '' then
do
if  Positioning1 = '<' then
UserValue = BeingAdded || ';' || UserValue
else
UserValue = UserValue || BeingAdded || ';'
end
UserValue = FixPathExt(UserValue)
return(UserValue)

RequiredFile: procedure expose LineNum ScriptLine
FullName = stream(arg(1), 'c', 'query exists')
if  FullName = '' then
Die('Required file "' || arg(1) || '" could not be found')
return(FullName)

ExpandVariables:
RightBit = arg(1)
LeftBit  = ''
VarPos = pos(VarStart, RightBit)
do  while VarPos <> 0
LeftBit  = LeftBit || left(RightBit, VarPos-1)
RightBit = substr(RightBit, VarPos+VarStartL)
EndPos = pos(VarEnd, RightBit)
if  EndPos = 0 then
Die('Could not find end of variable in: ' || RightBit)
VarName = left(RightBit, EndPos-1)
RightBit = substr(RightBit, EndPos+VarEndL)
select
when VarName = "STD:VERSION" then
VarContents = Pgmversion
when VarName = "STD:VARSTART" then
VarContents = VarStart
when VarName = "STD:VAREND" then
VarContents = VarEnd
when VarName = "STD:CDIR" then
VarContents = directory()
when VarName = "STD:RitFile" then
VarContents = RitFile
when VarName = "STD:RITPATH" then
do
SlashPos = lastpos('\', RitFile)
if  SlashPos = 0 then
VarContents = ''
else
VarContents = left(RitFile, SlashPos)
end
when abbrev(VarName, "FULLNAME:") then
do
ShortName   = substr(VarName, 10)
VarContents = RequiredFile(ShortName)
end
when abbrev(VarName, "GETENV:") then
do
EnvVar      = substr(VarName, 8)
VarContents = GetEnv(EnvVar)
if  VarContents = '' then
Die('The environment variable "' || EnvVar || '" does not exist')
end
when abbrev(VarName, "REG:") then
do
Stuff = substr(VarName, 5)
parse var Stuff RegRoot '/' RegKey '/' RegValue
hUser       = w32RegOpenKey(RegRoot, RegKey)
VarContents = w32RegQueryValue(hUser, RegValue)
QueryRc = Rc
call w32regclosekey hUser
if  QueryRc <> 0 then
Die('Registry value "' || Stuff || '" unknown' )
end
when abbrev(VarName, "?") then
do
RexVar = substr(VarName, 2)
if  symbol(RexVar) <> 'VAR' then
Die('The rexx variable "' || RexVar || '" does not exist')
VarContents = value(RexVar)
end
otherwise
do
Alias = 'VAR_' || c2x(VarName)
if  symbol(Alias) = 'VAR' then
VarContents = value(Alias)
else
Die('The user defined variable "' || VarName || '" does not exist')
end
end
LeftBit = LeftBit || VarContents
VarPos = pos(VarStart, RightBit)
end
return(LeftBit || RightBit)

_w32RegSetValue:
if  w32RegSetValue(arg(1), arg(2), arg(3), arg(4)) then
Die('Failed to set "' || arg(2) || '" in key "' || arg(1) || '"')
return

MakeSureRequiredDllsAreAvailable:
signal ON  SYNTAX  NAME SysIniMissing
call rxfuncadd 'w32loadfuncs', 'w32util', 'w32loadfuncs'
call w32loadfuncs
return

SysIniMissing:
Reason = ''
signal ON  SYNTAX  NAME NoErrMsgCall
Reason = RxFuncErrMsg()

NoErrMsgCall:
CrLf = d2c(13) || d2c(10)
if  Reason = '' then
Die("Can't load W32UTIL.DLL.' || CrLf || 'If on WIN95 'C' runtime must be available!")
else
Die('Can''t load "W32UTIL.DLL" (' || Reason || ').' || CrLf || 'If on WIN95 'C' runtime probably needs installation!')

ExecuteRexx:
interpret arg(1)
return

FixPathExt: procedure expose LineNum ScriptLine
PathExt = arg(1)
do  while left(PathExt, 1) = ';'
PathExt = substr(PathExt, 2)
end
do  while right(PathExt, 1) = ';'
PathExt = left(PathExt, length(PathExt)-1)
end
Colon2 = ';' || ';'
FixPos = pos(Colon2, PathExt)
Colon2 = ';' || ';'
do  while FixPos <> 0
PathExt = left(PathExt, FixPos-1) || substr(PathExt, FixPos+1)
FixPos = pos(Colon2, PathExt)
end
return(PathExt)

MakeAlias: procedure expose LineNum ScriptLine
New  = ''
From = arg(1)
do  Index = 1 to length(From)
ThisChar = substr(From, Index, 1)
if  ThisChar == ' ' | datatype(ThisChar, 'A') then
New = New || ThisChar
end
New = translate(space(New), '_', ' ')
return(New)

ShowHeader:
if  ShownHeader = 'N' then
do
say '[]------------------------------------[]'
say '| REGIT.REX v' || PgmVersion || ', "Super" associate |'
say '[]------------------------------------[]'
say ''
ShownHeader = 'Y'
end
return

ShowSyntax:
call ShowHeader
say 'SYNTAX'
say '~~~~~~'
say 'REGIT[.REX] RitFile[.RIT]'
say ''
say 'This program replaces Windows "ASSOC" and "FTYPE" commands with much more'
say 'powerful facilities and creates other associations such as updating icons,'
say 'descriptions and right click menus or extensions or file types. No registry'
say 'knowledge is required.'
return

GetEnv:
return( value(arg(1),,'ENVIRONMENT') )

Die:
ExitCode = SIGL
if  LineNum.IncludeLvl <> '' then
LineNum.IncludeLvl = '(' || LineNum.IncludeLvl || ')'
say ''
say 'ERROR' || LineNum.IncludeLvl || ': ' || arg(1) || d2c(7)
call ExitingWithErrorCode ExitCode

CommonTrapHandler:
FailingLine     = arg(1)
TrapHeading     = 'BUG: ' || arg(2)
TextDescription = arg(3)
Text            = arg(4)
parse source . . SourceFileName
say copies('=+', 39)
say TrapHeading
say copies('~', length(TrapHeading))
say substr(TextDescription, 1 , 16) || ': ' || Text
say 'Failing Module  : ' || SourceFileName
say 'Failing Line #  : ' || FailingLine
say 'Failing Command : ' || strip(SourceLine(FailingLine))
say 'Script Line #   : ' || LineNum.IncludeLvl
say 'Script Line     : ' || ScriptLine
say copies('=+', 39)
call ExitingWithErrorCode FailingLine

RexxTrapUninitializedVariable:
FatalLine = SIGL
call CommonTrapHandler FatalLine, 'NoValue Abort!', 'Unknown Variable', condition('D')

RexxTrapSyntaxError:
FatalLine = SIGL
call CommonTrapHandler FatalLine, 'Syntax Error!', 'Reason', errortext(Rc)

ExitingWithErrorCode:
call charout , d2c(7)
call sleep 1
address system 'pause'
exit( arg(1) )