/*----------------------------------------------------------------------------*/
/* Copyright (c) 2008-2014 Rexx Language Association. All rights reserved.    */
/*                                                                            */
/* This program and the accompanying materials are made available under       */
/* the terms of the Common Public License v1.0 which accompanies this         */
/* distribution. A copy is also available at the following address:           */
/* https://www.oorexx.org/license.html                                        */
/*                                                                            */
/* Redistribution and use in source and binary forms, with or                 */
/* without modification, are permitted provided that the following            */
/* conditions are met:                                                        */
/*                                                                            */
/* Redistributions of source code must retain the above copyright             */
/* notice, this list of conditions and the following disclaimer.              */
/* Redistributions in binary form must reproduce the above copyright          */
/* notice, this list of conditions and the following disclaimer in            */
/* the documentation and/or other materials provided with the distribution.   */
/*                                                                            */
/* Neither the name of Rexx Language Association nor the names                */
/* of its contributors may be used to endorse or promote products             */
/* derived from this software without specific prior written permission.      */
/*                                                                            */
/* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS        */
/* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT          */
/* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS          */
/* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   */
/* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,      */
/* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED   */
/* TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,        */
/* OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY     */
/* OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING    */
/* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS         */
/* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.               */
/*                                                                            */
/*----------------------------------------------------------------------------*/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*\
  File: OleUtils.frm

  Purpose:
    Provides some useful utilities for working with the .OLEObject class.

  Assumes:
    ooRexx version 4.0.0 as a minimum.

  Notes:
    This framework was originally written to work on ooRexx 3.1.2.  However,
    that was in the previous decade.  This version of OleUtils.frm now requires
    ooRexx 4.0.0 at a minimum.

  Public Routines:
    This is a list of the public routines and their syntax.  Arguments in square
    brackets indicate they are optional. Complete details on usage is in the
    header comments for each routine.

      oleOjbect = createOleOjbect(id, [verbose])
      boolean   = displayKnownMethods(oleObj, [verbose])
      boolean   = displayKnownConstants(oleObj)
      boolean   = isRexxTrue(obj)
      boolean   = isOORexx4OrLater()
      mode      = getAddressingMode()

\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/

-- End of entry point.

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*\
  Directives, Classes, or Routines.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/

/* createOleObject( id ) - - - - - - - - - - - - - - - - - - - - - - - - - - -*\

  Creates an .OLEObject instance, a proxy for the specified COM object.  This
  routine is used to trap the REXX error that happens when the proxied COM
  object can not be created.

  Input:
    id       REQUIRED
      The string used to create the COM object.  I.e., the ProgID or CLSID.

    verbose  OPTIONAL
      If true and the OleObject is not created, the error message is displayed.
      If false, the default, the message is not displayed.

  Returns:
    An instance of .OLEObject on success, .nil on failure.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  createOleObject public
  use strict arg id, verbose = .false

  if isRexxTrue(verbose) then
    verbose = .true
  else
    verbose = .false

  signal on syntax name returnNil

  oleObject = .OLEObject~new(id, "NOEVENTS")
  signal on syntax
  return oleObject

returnNil:
  signal on syntax
  if verbose then
    say "Error" rc":" errortext(rc)||'0d0a'x||condition('o')~message

  return .nil
-- End createOleObject( id, verbose )

/* displayKnownMethods( oleObj, verbose )- - - - - - - - - - - - - - - - - - -*\

  Formats and displays the known methods of an .OLEObject instance.  Known
  methods can only be displayed for OLE / COM objects that provide TypeInfo.  If
  there is no known information, a simple string stating as much is displayed.

  Input:
    oleObj REQUIRED
      An instance of the .OLEObject whose known methods are to be displayed.

    verbose  OPTIONAL
      If true all information concerning the methods is displayed.  Parameters,
      parameter types, return type, etc..  If false, the default, only the
      method names are displayed.

  Returns:
    0 if the specified object is not an instance of the .OLEObject classs,
    otherwise 1.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  displayKnownMethods public
  use strict arg oleObj, verbose = .false

  if \ oleObj~isInstanceOf(.OLEObject) then do
    say "Known methods can only be displayed for instances of the .OLEObject."
    say "  Arg 1 class:" oleObj~class
    return 0
  end

  if isRexxTrue(verbose) then
    verbose = .true
  else
    verbose = .false

  say
  j = printInstanceInfo(oleObj)

  known. = oleObj~getKnownMethods

  if known. == .nil then do
    say "There is no known method information for this object"
    return 1
  end

  say "Containing Type Library:" known.!LIBNAME
  if known.!LIBDOC~left(2) <> "!L" then
    say "Library Description:    " known.!LIBDOC
  say

  say "COM Class:        " known.!COCLASSNAME
  if known.!COCLASSDOC~left(2) <> "!C" then
    say "Class Description:" known.!COCLASSDOC
  say "Known methods:    " known.0
  say

  if \ verbose then do
    say "  Methods:"
    do i = 1 to known.0
      say "    " known.i.!NAME
    end
    return 1
  end

  do i = 1 to known.0
    ret  = known.i.!RETTYPE
    name = known.i.!NAME
    doc  = known.i.!DOC
    invk = known.i.!INVKIND

    say " " name

    if doc~pos("!DOC") == 0 then
      say "    Decscription:" doc

    say "   " invkindToString(invk) "returns" ret
    say

    if ret == "VT_VOID" then
      line = "      obj~"name
    else
      line = "      " || changeVariant(ret) || "= obj~"name

    select
      when invk == 2 then
        say line

      when known.i.!PARAMS.0 == 0 then
        say line"()"

      otherwise do
        line   = line"( "
        indent = " "~copies(line~length)

        do j = 1 to known.i.!PARAMS.0
          param = known.i.!PARAMS.j.!TYPE known.i.!PARAMS.j.!FLAGS             -
                  known.i.!PARAMS.j.!NAME

          select
            when j == 1 & known.i.!PARAMS.0 == 1 then do
              say line || param" )"
            end
            when j == 1 then do
              say line || param","
            end
            when j == known.i.!PARAMS.0 then do
              say indent || param" )"
            end
            otherwise do
              say indent || param","
            end
          end
          -- End select
        end
        -- End do j = 1 to known.i.!PARAMS.0
      end
      -- End otherwise do
    end
    -- End select

    say
  end
  -- End do i = 1 to known.0

return 1
-- End displayKnownMethods( oleObj )

/* displayKnownConstants( oleObj ) - - - - - - - - - - - - - - - - - - - - - -*\

  Prints out all the known constants for the specified object, if any are
  available.

  Input:
    oleObj  REQUIRED
      An instance of the .OLEObject whose known methods are to be displayed.

  Returns:
    0 if the oleObj argument was not an instance of .OLEObject, otherwise 1.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  displayKnownConstants public
  use strict arg oleObj

  if \ oleObj~isInstanceOf(.OLEObject) then do
    say "Known constants can only be displayed for instances of the .OLEObject."
    say "  Arg 1 class:" oleObj~class
    return 0
  end

  say
  j = printInstanceInfo(oleObj)

  constants = oleObj~getConstant
  if constants == .nil | constants~items == 0 then do
    say "There are no known constants for this object"
    return 1
  end

  say "Known constants:" constants~items
  say

  -- Some of Microsoft's constant names are very long.
  line = " "~copies(42) || "= "
  do name over constants
    say line~overlay(name~substr(2), 3) || constants[name]
  end

return 1
-- End displayKnownConstants( oleObj )

/* isRexxTrue( obj ) - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*\

  Tests if obj is strictly .true.  (To some degree, actually just tests that obj
  is exactly '1'.)

  Input:
    obj REQUIRED
      The object to test.

  Returns:
    True if obj is strictly true, otherwise false.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  isRexxTrue public
  use strict arg obj

  if obj~class == .string then
    if obj~datatype('W') then
      if obj == 1 then
        return .true

return .false
-- End isRexxTrue( obj )

/* isOORexx4OrLater( ) - - - - - - - - - - - - - - - - - - - - - - - - - - - -*\

  Returns true if the running interpreter is ooRexx 4.0.0 or later.

  Input:
    None.

  Returns:
    True if this is ooRexx 4.0.0 or later, otherwise false.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  isOORexx4OrLater public
  use strict arg

  parse version interpreterName languageLevel interpreterDate
  parse var interpreterName junk "_" ver "." moreJunk
  if ver >= 4 then return .true

return .false
-- End isOORexx4OrLater( )

/** getAddressingMode()
 * Determine if this is a 32-bit or 64-bit interpreter.
 */
::routine  getAddressingMode public
  use strict arg

  parse version rexx'_'ver'_'mode'-bit' .
  return mode

return mode

/* changeVariant( vt ) - - - - - - - - - - - - - - - - - - - - - - - - - - - -*\

  Helper function to turn a VARTYPE symbol into a "prettified" object name.

  E.g., VT_DISPATCH becomes dispatchObj, VT_I4 becomes i4Obj.

  Input:
    vt REQUIRED

  Returns:
    The prettified version of the specified VARTYPE.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  changeVariant
  use strict arg vt

  -- TODO: it would be nice to turn VT_I4 to something like int4ByteObj, VT_R4
  -- to float4ByteObj, etc.
  retStr = vt~substr(4) || "Obj"

return retStr~lower
-- End changeVariant( vt )

/* invkindToString( kind ) - - - - - - - - - - - - - - - - - - - - - - - - - -*\

  Helper function to return a string value for the specified invocation type.

  Input:
    kind REQUIRED
      A number representing a COM INVOKEKIND enumeration.

  Returns:
    Returns the enumeration symbol, (string symbol) for the specified kind.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  invkindToString
  use strict arg kind

  select
    when kind == 1 then
      kindString = "<Function>"
    when kind == 2 then
      kindString = "<Property get>"
    when kind == 4 then
      kindString = "<Property put>"
    when kind == 8 then
      kindString = "<Property put by reference>"
    otherwise
      kindString = "<Error Invalid! ("kind")>"
  end
  -- End select

return kindString
-- End invkindToString( kind )

/* printInstanceInfo( oleObj ) - - - - - - - - - - - - - - - - - - - - - - - -*\

  Helper function to print out instance information for an .OLEObject object.

  Input:
    oleObj REQUIRED
      The object whose instance information is to be printed.

  Returns:
    0, always.
\* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
::routine  printInstanceInfo
  use strict arg oleObj

  progID   = oleObj~!getVar("!PROGID")
  clsID    = oleObj~!getVar("!CLSID")
  disp     = oleObj~!getVar("!IDISPATCH")
  typeInfo = oleObj~!getVar("!ITYPEINFO")

  if isOORexx4OrLater() then do
    if progID == .nil then
      progID = "null"
    if clsID == .nil then
      clsID = "null"
    if disp == .nil then
      disp = "null"
    if typeInfo == .nil then
      typeInfo = "null"
  end
  else do
    if progID~left(2) == "!P" then
      progID = "null"
    if clsID~left(2) == "!C" then
      clsID = "null"
    if disp~left(3) == "!ID" then
      disp = "null"
    if typeInfo~left(3) == "!IT" then
      typeInfo = "null"
  end

  say "ProgID:          " progID
  say "ClsID:           " clsID
  say "Dispatch Pointer:" disp
  say "TypeInfo Pointer:" typeInfo
  say

return 0
-- End printInstanceInfo( oleObj )



/* - - - - - - - - - - End of file: OleUtils.frm- - - - - - - - - - - - - - - */
