/*----------------------------------------------------------------------------*/ /* 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 = "" when kind == 2 then kindString = "" when kind == 4 then kindString = "" when kind == 8 then kindString = "" otherwise kindString = "" 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- - - - - - - - - - - - - - - */