/*
 *
 *  Gets setup strings from .rc files and
 *  creates or destroys WPS objects by them.
 *  Registers and replaces classes,
 *  creates keys in selected .ini files.
 *  .rc file (like ini.rc in \os2)
 *  is the template in text format
 *  for creating .ini binary files.
 *  Syntax: crobj [global opts] [[local opts1] <file1.rc>] ... [[local optsN] <fileN.rc>]
 *  or: cat <file.rc> | crobj [global opts]
 *  where [global opts] can be:
 *  '-h' -- Give Help
 *  '-I' -- One global ini file for all selected .rc's
 *  '-U' -- Global undo: undo all the following .rc's
 *
 *  [local opts] can be:
 *  '-i' -- local .ini file for one selected .rc
 *  '-u' -- local undo: undo one the following .rc
 *
 *  (c) valerius, 2006 Jun 2,
 *  _valerius (at-sign) mail (dot) ru
 *  licensed under BSD license.
 *
 */

/*
 *  ToDo: undo .rc files
 *  instead of applying them;
 */


parse arg args

call ParseCmdLine args

call InitRxDlls
call GetObjIds


/* defaults: */
InComment = 0
countCommented = 0;

/* commentary symbols */
BeginComment = '/*'
EndComment   = '*/'

CommentVars = 'InComment countCommented',
              'BeginComment EndComment'

if opt.Help = 1 then do
  call GiveHelp
  exit 0
end

BackupFolder = 'Preserved'
BackupID = '<PRG_BACKUPFLD>'

/* Apply several .rc files in the order */
do num = 1 to infile.0

  infile = infile.num

  /* Reading all lines in order: */
  if infile \= '' then
    rc = stream(infile, 'c', 'open read')

  /* Process each .rc file */
  lines = 0
  do while lines(infile) > 0
    line = linein(infile)
    lines = lines + 1
    line = strip(line)
    call processLine line
  end

  if infile \= '' then
    rc = stream(infile, 'c', 'close')

end


exit 0
/* ------==========------- */
ParseCmdLine: procedure expose infile. opt.
args = arg(1)


drop opt.

/*
 *  opt.  -- options stem
 *  opt.i -- options subtree for i'th .rc file,
 *  where 'i' is .rc file number
 */

opts = args
count = 0
inis = 0
opt.ini = ''

do while opts \= ''

  count = count + 1
  opt = getarg()

  if pos('-', opt) == 1 then
    select
      when opt = '-U'
        /* Global Undo option: undo all
           the following .rc files     */
        then opt.Undo = 1

      when opt = '-u'
        /* Local Undo: undo one
           following .rc file          */
        then do
          count = count + 1
          opt = getarg()
          infile.count = opt
          opt.count.Undo = 1
          opt.count.Ini = opt.ini
        end

      when opt = '-i'
        /* Apply the following .rc files to
                  this .ini file            */
        then do
          inis = inis + 1
          count = count + 1
          opt = getarg()
          opt.ini = opt
        end

      when opt = '-h'
        /* Give Help */
        then opt.Help = 1

      otherwise nop
    end
  else do
    infile.count = opt
    /* .ini file for count'th .rc file to apply */
    opt.count.Ini = opt.ini
  end
end
infile.0 = count

if count = 0 then do
  infile.0 = 1
  infile.1 = ''
end

drop opt.ini


return
/* ------==========------- */
getarg: procedure expose opts

/* Gets one word, or a line, enclosed
   in quotes, from opts               */

opts = strip(opts)

if pos('"', opts) == 1 then
  parse value opts with '"' opt '"' opts
else
  parse var opts opt opts


return opt
/* ------==========------- */
InitRxDlls: procedure

  call RxFuncAdd 'SysLoadFuncs', 'rexxutil', 'SysLoadFuncs'
  call SysLoadFuncs

  call RxFuncAdd 'WPToolsLoadFuncs', 'wptools', 'WPToolsLoadFuncs'
  call WPToolsLoadFuncs


return
/* ------==========------- */
processLine: procedure expose (CommentVars),
                              lines infile,
                              opt. opts. keys.
line = arg(1)


p1 = 1; p2 = 1;

do while p1 + p2 > 0

  /* Comment deleting */
  /* Comments can't be nested */

  p1 = pos(BeginComment, line);
  p2 = pos(EndComment, line);

  /* Deleting the first comment in a line */
  if (0 < p1) & (p1 < p2) then do
    line = delstr(line, p1, p2 - p1 + 2)
  end; else if (0 < p2) & ((p2 < p1) | (p1 == 0)) then do
    line = substr(line, p2 + 2);
    InComment = 0;
    countCommented = 0;
  end; else if p1 > 0 then do

    line = delstr(line, p1);
    InComment = 1
  end

  line = strip(line)

  /* Skipping the lines inside the comment */
  if InComment > 0 then countCommented = countCommented + 1;
  if countCommented > 2  then return;

  /* Processing the line after deleting all the comments */
  if p1 + p2 == 0 then do

    if line = '' then return;

    if pos('"', line) == 0 then do
      /* Upper Case: */
      line = translate(line)
      parse var line keyword opt
      select
        when keyword == 'CODEPAGE'    then
          opt.CodePage = opt

        when keyword == 'STRINGTABLE' then
          if opt = 'REPLACEMODE' then
            opt.Replace = 1
          else
            opt.Replace = 0

        when keyword == 'BEGIN'       then
          opt.Section = prev

        when keyword == 'END'         then
          opt.Section = ''

        otherwise nop

      end

      prev = keyword

      return;
    end

    /*
    parse var line '"' name '"' line
     */

    call splitLine line
    name = opts.app

    select

      when name == '' then return;

      when name == 'PM_InstallObject'
        then call processInstallObj;

      when name == 'PM_InstallClass'
        then call processInstallClass    line;

      when name == 'PM_InstallClassReplacement'
        then call processInstallClassRep line;

      when name == 'PM_MigrateFolder'
        then nop

      when name == 'PM_RunInstallProgram'
        then nop

      otherwise
        call processAddKey '"'name'"  'line;

    end;

    return;
  end;
end;


return
/* ------==========------- */
processInstallObj: procedure expose lines,
                                    infile keys.,
                                    opts.


/* Processing of the "PM_InstallObject" lines */

line = opts.key
opts.setup = opts.val

parse var line opts.name ';' opts.class ';' opts.location ';' opts.opt

opts.opt = strip(opts.opt, 'T', ';')

/* Determining the Object Id */
str = opts.setup

ObjId = ''
do while str \= ''
  parse var str parm '=' value ';' str
  parm = translate(parm)
  value = strip(value, 'T', ';')
  if parm == 'OBJECTID' then do
    ObjId = value
    leave
  end
end

title = ''
str = opts.setup

do while str \= ''
  parse var str parm '=' value ';' str
  parm = translate(parm)
  value = strip(value, 'T', ';')
  if parm == 'TITLE' then do
    title = value
    leave
  end
end


if infile = '' then
  file = 'stdin'
else
  file = infile

if ObjId = '' then do
  ret = -255
  call lineout 'stderr', 'Error 'ret': empty object id!'
  call lineout 'stderr', 'rc file: 'file','
  call lineout 'stderr', 'line: 'lines
  exit ret
end

if oprs.name = '' then opts.name = title

if opts.name = '' then do
  ret = -254
  call lineout 'stderr', 'Error 'ret': no object name and no title!'
  call lineout 'stderr', 'rc file: 'file','
  call lineout 'stderr', 'line: 'lines
  exit ret
end

if opts.class = '' then do
  ret = -253
  call lineout 'stderr', 'Error 'ret': no object class!'
  call lineout 'stderr', 'rc file: 'file','
  call lineout 'stderr', 'line: 'lines
  exit ret
end

if opts.location = '' then do
  ret = -252
  call lineout 'stderr', 'Error 'ret': no object location!'
  call lineout 'stderr', 'rc file: 'file','
  call lineout 'stderr', 'line: 'lines
  exit ret
end

/*
call SysSleep 0.1
 */

select

 when opts.opt == 'FAIL' then do
   /* Do nothing if an object already exists or create
      the new object if it didn't exist            */
   opts.opt = 'F';
   call lineout 'stderr', 'Failing if target object exist: 'ObjId'...'
   rc = SysCreateObject(opts.class, opts.name, opts.location, opts.setup, opts.opt);
 end;

 when opts.opt == 'PRESERVEOLD' then do
  /* Preserve old object with renamed Object Id
     and create new object with these settings with
     the object id in these settings -- as the old
     object had                                    */
   opts.opt = 'R';
   call lineout 'stderr', 'Preserving old 'ObjId'...'
   p = pos('>', ObjId)
   if p <= 0 then p = length(ObjId) + 1

   f = 0
   cnt = 0
   do until f
     cnt = cnt + 1
     newid = insert('_'cnt, ObjId, p - 1)
     f = \ObjExists(newid)
   end

   ret = WPToolsQueryObject(ObjId,,
                            'class1',,
                            'title1',,
                            'setup1',,
                            'location1')
   if ret then do

     newname = insert('_'cnt, name, length(name))
     newsetup = setup
     parse var newsetup first 'OBJECTID=' second ';' last
     newsetup = first'OBJECTID='newid';'last

     rc = SysCreateObject(class1, newname, location1, newsetup, 'U')

     if class1 = 'WPFolder'     |,
        class1 = 'XWPFolder'    |,
        class1 = 'MMFolder'     |,
        class1 = 'WPUrlFolder'  |,
        class1 = 'WPDesktop'
     then do

       ret = WPToolsFolderContent(newid, 'objs.', F)

       if ret then do
         do i = 1 to objs.0
           obj = obj.i
           ret = WPToolsQueryOnject(obj,,
                                    'class2',,
                                    'title2',,
                                    'setup2',,
                                    'location2')
           if ret then do
             parse var setup2 first 'OBJECTID=' second ';' last
             location2 = newid
             ret = SysMoveObject(second, location2)
             ret = SysCreateObject(class2, title2, location2, setup2, 'U')
           end
           else do
             call lineout 'stderr', 'Can''t query object properties: 'second'!'
             exit -1
           end
         end
       end
       else do
         call lineout 'stderr', 'Can''t query folder confent: 'newid'!'
         exit -2
       end
     end
   end

   rc = SysCreateObject(opts.class, opts.name, opts.location, opts.setup, opts.opt);
 end;

 when opts.opt == 'REPLACE'     then do
   /* Delete an old object and create new one      */
   opts.opt = 'R';
   call lineout 'stderr', 'Replacing 'ObjId'...'
   rc = SysCreateObject(opts.class, opts.name, opts.location, opts.setup, opts.opt);
 end;

 when opts.opt == 'RELOCATE'     then do
   /* Find the object 'ObjId', move it to the new folder and apply setup string */
   opts.opt = 'U'
   call lineout 'stderr', 'Relocating 'ObjId' to folder: 'location'...'
   rc = SysMoveObject(ObjId, opts.location)
   rc = SysCreateObject(opts.class, opts.name, opts.location, opts.setup, opts.opt);
 end;

 when opts.opt == 'UPDATE'      then do
   /* Update properties, if an object already exists */
  call lineout 'stderr', 'Updating 'ObjId'...'
   opts.opt = 'U';
   rc = SysCreateObject(opts.class, opts.name, opts.location, opts.setup, opts.opt);
 end;

 when opts.opt == 'UPDATEONLY'  then do
   /* What's the difference from 'UPDATE'? Please let me know (if you know) */
   /* My hypotesis on this is that only SETUP string is updated, not other  */
   call lineout 'stderr', 'Updating only setup string: 'ObjId'...'
   opts.opt = 'U';
   rc = SysSetObjectData(ObjId, opts.setup);
 end;

 when opts.opt == 'DELETE'      then
   /* Delete object with given settings            */
   call DeleteObj;

 otherwise do
   /* By default, Update the settings of the object */
   opts.opt = 'U';
   rc = SysCreateObject(opts.class, opts.name, opts.location, opts.setup, opts.opt);
 end;

end;


return
/* ------==========------- */
splitLine: procedure expose opts.
line = arg(1)
q = 0

drop opts.
line = strip(line)

opts.app = quotedText()
opts.key = quotedText()
opts.val = quotedText()
opts.comment = commentedText()

return
/* ------==========------- */
quotedText: procedure expose line q

p = pos('"', line, q + 1)

if p > 0 then do

  t = p
  do forever
    q = pos('"', line, p + 1)
    if q > 1
      then do
        if substr(line, q - 1, 1) \= '^'
          then
            leave
          else do
            s1 = substr(line, 1, q - 2)
            s2 = substr(line, q)
            line = s1 || s2
            p = q - 1
          end
      end
  end

  s = substr(line, t + 1, q - t - 1)

end
else
  parse var line s line


return s
/* ------==========------- */
commentedText: procedure expose line q

p = pos('/*', line, q + 1)
if p > 0 then do

  q = pos('*/', line, p + 1)
  s = substr(line, p + 2, q - p - 3)

end
else
  parse var line '/*' s '*/' line

  s = strip(s)
  line = strip(line)


return s
/* ------==========------- */
GetObjIds: procedure expose keys.

call SysIni 'USER', 'PM_Workplace:Location', 'ALL:', 'keys.'


return
/* ------==========------- */
ObjExists: procedure expose keys.
objid = arg(1)

/* Check if object with Id = objid exist */

do i = 1 to keys.0
  key = keys.i
  if objid = key then return 1
end


return 0
/* ------==========------- */
DeleteObj: procedure expose file lines,
                            ObjId opts.


   if \WPToolsQueryObject(opts.location,,
                          'prop.Class1',,
                          'prop.Title1',,
                          'prop.Setup1',,
                          'prop.Location1') then do
     ret = -251
     call lineout 'stderr', 'Error 'ret': location folder doesn''t exist!'
     call lineout 'stderr', 'rc file: 'file','
     call lineout 'stderr', 'line: 'lines
     exit ret
   end


   if WPToolsFolderContent(opts.location, 'objs', 'F') then do

     ObjExists = 0
     do i = 1 to objs.0
       if WPToolsQueryObject(objs.i,,
                             'prop.Class1',,
                             'prop.Title1',,
                             'prop.Setup1',,
                             'prop.Location1')

       then do

         str = prop.Setup1
         prop.ObjId1 = ''

         do while str \= ''
           parse var str parm '=' value ';' str
           parm = translate(parm)
           value = strip(value, 'T', ';')
           if parm == 'OBJECTID' then do
             prop.ObjId1 = value
             leave
           end
         end

         if opts.name  = prop.Title1 &,
            opts.class = prop.Class1 &,
            ObjId = prop.ObjId1  then do

           ObjExists = 1
           leave

         end

       end
       else do
         call lineout 'stderr', 'Can''t query object properties: 'objs.i'!'
         exit -250
       end
     end

   end
   else
     call lineout 'stderr', 'Can''t query folder content!: 'location' (WPToolsFolderContent)'

   if ObjExists then do
     call lineout 'stderr', 'Destroying 'ObjId'...'
     rc = SysDestroyObject(ObjId)
   end
   else do
     call lineout 'stderr', 'No such object 'ObjId' with given properties!'
     exit -250
   end


return
/* ------==========------- */
processInstallClass: procedure
line = arg(1)

/* Processing of the "PM_InstallClass" lines */

parse var line '"' class '"' . '"' module '"' .

ret = SysRegisterObjectClass(class, module)

if ret \= 'ERROR:' then do
  call lineout , 'Registering object class: 'class' in module: 'module', done...'
end
else do
  call lineout , 'Registering object class: 'class' in module: 'module', fail...'
  exit -248
end


return
/* ------==========------- */
processInstallClassRep: procedure
line = arg(1)

/* Processing of the "PM_InstallClassReplacement" lines */

parse var line '"' class '"' . '"' rep '"' .

ret = SysIni('USER', 'PM_Workplace:ReplaceList', 'ALL:', 'list.')

if ret \= 'ERROR:' then do
  found = 0
  do i = 1 to list.0
    oldclass = list.i
    if oldclass == class then found = 1
    replist = SysIni('USER', 'PM_Workplace:ReplaceList', oldclass)
    leave
  end
  ending = '0000'x

  if found then do
    p = length(replist)
    if pos(ending, replist) == p - 1 then do
      replist = delstr(replist, p)
      replist = replist || rep || ending
      ret = SysIni('USER', 'PM_Workplace:ReplaceList', oldclass, replist)
      if ret \= 'ERROR:' then
        call lineout , 'Replacing object class: 'class' by class: 'rep', done...'
      else do
        call lineout , 'Replacing object class: 'class' by class: 'rep', fail...'
        exit -247
      end
    end
  end
  else do
    replist = rep || ending
    ret = SysIni('USER', 'PM_Workplace:ReplaceList', oldclass, replist)
    if ret \= 'ERROR:' then
      call lineout , 'Replacing object class: 'class' by class: 'rep', done...'
    else do
        call lineout , 'Replacing object class: 'class' by class: 'rep', fail...'
        exit -247
    end
  end
end
else do
  call lineout 'stderr', 'SysIni: can''t query keys list for ''PM_Workplace:ReplaceList''!'
  exit -247
end


return
/* ------==========------- */
processAddKey: procedure
line = arg(1)

/* Adding the arbitrary keys into the current .INI file */

/*
parse var line '"' app '"' . '"' key '"' . '"' val '"' .
 */

call splitLine line

ini = 'USER'
ret = SysIni(ini, opts.app, opts.key, opts.val)

if ret \= 'ERROR:' then do
  call lineout 'stderr', 'Setting app: '''opts.app''', key: '''opts.key''', value: '''opts.val''' in ini: '''ini''': Done...'
end
else do
  call lineout 'stderr', 'Setting app: '''opts.app''', key: '''opts.key''', value: '''opts.val''' in ini: '''ini''': Fail...'
  exit -246
end


return
/* ------==========------- */
GiveHelp:

call lineout 'stderr', ''
call lineout 'stderr', 'Syntax: crobj [global opts] [[local opts1] <file1.rc>] ... [[local optsN] <fileN.rc>]'
call lineout 'stderr', 'or: cat <file.rc> | crobj [global opts]'
call lineout 'stderr', 'where [global opts] can be:'
call lineout 'stderr', '''-h'' -- Give Help'
call lineout 'stderr', '''-I'' -- One global ini file for all selected .rc''s'
call lineout 'stderr', '''-U'' -- Global undo: undo all the following .rc''s '
call lineout 'stderr', ''
call lineout 'stderr', '[local opts] can be:'
call lineout 'stderr', '''-i'' -- local .ini file for one selected .rc  '
call lineout 'stderr', '''-u'' -- local undo: undo one the following .rc'
call lineout 'stderr', ''


return
/* ------==========------- */