Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src AXConList.F, NONE, 1.1 AxConInfo.f, NONE, 1.1 FCOM.F, NONE, 1.1 Unicode.F, NONE, 1.1
|
From: Jos v.d.V. <jo...@us...> - 2007-05-16 20:25:04
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv5856 Added Files: AXConList.F AxConInfo.f FCOM.F Unicode.F Log Message: Jos: Tom Dixon's COM files. --- NEW FILE: Unicode.F --- \ Unicode Words \ Tom Dixon anew -Unicode.f library OLE32.DLL library oleaut32.dll : UniPlace ( addr len destaddr -- ) \ *G Store a unicode string to an address 2dup ! 4 + 2dup + 0 swap w! swap cmove ; : +UniPlace ( addr len destaddr -- ) \ *G Append a string to the end of an address 2dup @ + >r dup >r dup @ + 4 + 2dup + 0 swap ! swap cmove r> r> swap ! ; : UniCount ( addr -- addr len ) \ *G Fetch a unicode string from an address (stored with uniplace) dup 4 + swap @ ; : ZUniCount ( addr -- addr len ) \ *G Fetch a null-terminated unicode string from an address (null is 16-bit) dup 0 begin over w@ while 2 2 d+ repeat nip ; : UniType ( addr len -- ) \ *G Type a unicode string to the console 2/ 0 ?do dup i 2* + c@ emit loop drop ; : (U") r> UniCount 2dup + 2 + aligned >r ; : Ustr, ( addr n -- ) \ *G Store a unicode string to the dictionary at HERE HERE over 6 + allot uniplace ALIGN ; : Asc>Uni ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!! \ *G Convert a ascii string to unicode.\n \ ** must free unicode string with 'free' when no longer needed. dup 2* dup allocate abort" Unable to Allocate Unicode String!" dup >r 2swap swap MB_PRECOMPOSED 0 call MultiByteToWideChar r> swap 2* ; : Uni>Asc ( str len -- str len ) \ !!! MUST FREE STRING AFTER !!! \ *G Convert a unicode string to ascii\n \ ** must free ascii string afterwards when no longer needed. 0 0 2over 0 here 2swap swap 0 0 call WideCharToMultiByte 2/ >r 0 0 2swap r@ dup Allocate abort" Unable to Allocate String!" dup >r 2swap swap 0 0 call WideCharToMultiByte drop r> r> ; : >Unicode ( str len -- str len ) \ *G Convert ascii string to unicode (uses new$) asc>uni 2dup new$ dup >r uniplace drop free drop r> unicount ; : >ascii ( str len -- str len ) \ *G Convert unicode string to ascii (uses new$) uni>asc 2dup new$ dup >r place drop free drop r> count ; : U" ( <string"> -- str len ) \ *G Unicode string - unicode version of s" [char] " PARSE >unicode compilation> drop [char] " PARSE asc>uni 2dup here -rot ustr, unicount postpone 2literal drop free drop ; \ Some APIs require more specific conditions to their unicode strings. \ (ie: distributed and network apis) \ bstr has more constraints applied to it. These words are to convert \ to bstrs and back again. : Asc>bstr ( str len -- bstr ) \ *G Convert ascii string to unicode bstr. bstr must be freed later with 'bstrfree'. dup dup 0 call SysAllocStringLen dup >r 2swap swap MB_PRECOMPOSED CP_ACP call MultiByteToWideChar drop r> ; : bstrFree ( bstr -- ) \ *G Free a bstr. call SysFreeString drop ; : bstrlen ( ustr -- len ) \ *G Returns the length of the bstr. From this the bstr can be used with all the \ ** other unicode functions. cell- @ ; \ *Z --- NEW FILE: AxConInfo.f --- \ $Id: AxConInfo.f,v 1.1 2007/05/16 20:24:58 jos_ven Exp $ \ AxConInfo.f \ Get informations about an ActiveX control from registry and \ display them. \ Written by Dirk Busch cr .( Loading ActiveX control info tool) anew -AxConInfo.f needs fcom internal in-system create org_BaseReg 260 allot create org_ProgReg 260 allot 0 value org_regBaseKey 0 value org_regAccessMask : SaveReg ( -- ) BaseReg count org_BaseReg place ProgReg count org_ProgReg place regBaseKey to org_regBaseKey regAccessMask to org_regAccessMask ; : RestoreReg ( -- ) org_BaseReg count BaseReg place org_ProgReg count ProgReg place org_regBaseKey to regBaseKey org_regAccessMask to regAccessMask ; : tab-type ( addr len -- ) tab-size >r 32 to tab-size tab type r> to tab-size ; : RegGetAxInfoValue ( addr1 len1 addr2 len2 -- addr3 len3 ) s" CLSID\" BaseReg place 2swap BaseReg +place \ guid s" \" BaseReg +place BaseReg +place \ section ProgReg off s" " s" " RegGetString ; : (.AxInfoValue) ( addr len -- ) 2dup type ." : " RegGetAxInfoValue tab-type ; : (.AxInfo) ( addr len -- ) cr ." GUID: " 2dup tab-type cr 2dup ." ClassName" s" " (.AxInfoValue) cr 2dup s" ProgID" (.AxInfoValue) cr 2dup s" TypeLib" (.AxInfoValue) cr 2dup s" Version" (.AxInfoValue) cr s" VersionIndependentProgID" (.AxInfoValue) cr ; : AxInitReg ( -- ) SaveReg HKEY_CLASSES_ROOT to regBaseKey KEY_READ to regAccessMask ; : AxRestoreReg ( -- ) RestoreReg ; : /get { str len char \ str1 len1 -- str len str1 len1 } \ search for char in string, return string till char and rest of string after char str len char scan to len1 to str1 len1 0> if len len1 - to len str1 1+ to str1 len1 1- ?dup if to len1 then then str len str1 len1 ; : guid>version ( addr len -- major minor ) s" Version" RegGetAxInfoValue ?dup if [char] . /get number? drop d>s >r number? drop d>s r> else drop 1 0 then ; : guid>typelib ( addr len -- addr len ) s" TypeLib" RegGetAxInfoValue ; external : GetAxVersion ( "GUID" -- major minor ) AxInitReg parse-word ?dup if guid>version else drop 0 0 then RestoreReg ; : GetAxTypeLib ( "GUID" -- addr len ) AxInitReg parse-word ?dup if guid>typelib else drop s" " then RestoreReg ; internal [undefined] (Guid,) [if] : (Guid,) ( addr len -- ) \ comments in a guid Base @ >r HEX dup 38 <> abort" Invalid Guid Length" 1 /string 2dup ascii - scan 2dup >r >r nip - hatoi , r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w, r> r> ascii - skip 2dup ascii - scan 2dup >r >r nip - hatoi w, r> r> ascii - skip 2dup drop 2 0 do dup i 2 * + 2 hatoi c, loop drop ascii - scan ascii - skip drop 6 0 do dup i 2 * + 2 hatoi c, loop drop r> base ! ; [then] : (guid_typelib) ( major minor addr len -- ) \ load a type library for given GUID into the list 2>r here typelibhead dup @ , ! here dup >r 0 , here 0 , 2swap swap here r> 2r> rot >r (Guid,) call LoadRegTypeLib abort" Error Loading Type Library" r> dup cell+ swap UCOM ITypeLib GetTypeComp abort" Error Getting TypeComp" ; external : guid_typelib ( "GUID" -- ) \ load a type library for given GUID into the list parse-word ?dup if AxInitReg 2dup guid>version 2swap guid>typelib (guid_typelib) RestoreReg else drop abort" GUID missing" then ; : .AxInfo ( "GUID" -- ) cr cr ." ActiveX Control info" parse-word ?dup if AxInitReg 2dup (.AxInfo) 2dup guid>version 2swap guid>typelib (guid_typelib) cr ." CoClasses:" tab CoClasses cr cr ." Interfaces:" tab Interfaces cr cr ." Structures:" tab Structures cr cr ." ComConsts:" tab ComConsts AxRestoreReg else drop then cr ; module in-application cr .( Usage: .axinfo <guid>) cr .( Example: .axinfo {0002DF01-0000-0000-C000-000000000046}) --- NEW FILE: AXConList.F --- \ $Id: AXConList.F,v 1.1 2007/05/16 20:24:58 jos_ven Exp $ \ Dump all installed ActiveX Controls to the console \ Thomas Dixon anew -AXConList.f needs fcom \ include the com library internal in-system \ define some guids UUID StdComponentCategoriesMgr {0002E005-0000-0000-C000-000000000046} UUID AXControl {40FC6ED4-2438-11cf-A3DB-080036F12502} \ I couldn't find a typelibrary for these interfaces, so I must statically \ define them. There are only two, so it's not bad. IUnknown Interface ICatInformation {0002E013-0000-0000-C000-000000000046} ICatInformation Open-Interface 3 3 IMethod EnumCategories ( *ppenumCategoryInfo lcid -- hres ) 4 4 IMethod GetCategoryDesc ( *pszDesc lcid rcatid -- hres ) 6 5 IMethod EnumClassesOfCategories ( *ppenumClsid rgcatidReq cReq rgcatidImpl cImp -- hres ) 6 6 IMethod IsClassOfCategories ( rgcatidReq cReq rgcatidImpl n clsid -- hres ) 3 7 IMethod EnumImplCategoriesOfClass ( *ppenumCatid rclsid -- hres ) 3 8 IMethod EnumReqCategoriesOfClass ( *ppenumCatid clsid -- hres ) Close-Interface IUnknown Interface IEnumGUID {0002E000-0000-0000-C000-000000000046} IEnumGUID Open-Interface 4 3 IMethod Next ( *n *rgelt celt -- hres ) 2 4 IMethod Skip ( *celt -- hres ) 1 5 IMethod Reset ( -- hres ) 2 6 IMethod Clone ( *ppenum -- hres ) Close-Interface \ Make a few interfaces ICatInformation comiface catinfo IEnumGUID comiface enumg create tempguid 16 allot \ temporary guid buffer external \ word to list controls : .axcontrols ( -- ) cr ." Listing all ActiveX controls:" cr catinfo ICatInformation 1 0 StdComponentCategoriesMgr call CoCreateInstance abort" Unable to initialize Control Manager!" enumg pad 0 axcontrol 1 catinfo EnumClassesOfCategories drop enumg reset drop begin 0 tempguid 1 enumg next 0= while pad tempguid call StringFromCLSID 0= if ." " pad @ zunicount unitype then pad 1 tempguid call OleRegGetUserType 0= if ." " pad @ zunicount unitype then cr repeat enumg IReleaseref drop catinfo IReleaseref drop ; MODULE .axcontrols in-application --- NEW FILE: FCOM.F --- \ Component Object Module Interface for Win32forth \ Tom Dixon needs Unicode anew -FCOM.f internal external library oleaut32.dll \ List Library (if not defined) [DEFINED] lrest NOT [IF] : cons ( node list -- list ) over ! ; : lrest ( list -- list ) @ ; : node, ( -- node ) here 0 , ; [THEN] [...1049 lines suppressed...] \ if, for one reason or another, you don't want to use the type libraries, you \ can define it yourself as shown below. \ 0 Interface IUnknown {00000000-0000-0000-C000-000000000046} \ IUnknown Open-Interface \ 3 0 IMethod IQueryInterface ( ppv riid -- hres ) \ 1 1 IMethod IAddRef ( -- refs ) \ 1 2 IMethod IReleaseRef ( -- refs ) \ Close-Interface \ you can do the same with structures, but there are better ways to do \ structures. \ My primary purpose in writing this was to make interfacing to COM just as \ easy as using a dll (if not more so). I tried to make it fast, which may \ have lost some of the readability. This only supports early-binding. This \ shouldn't be a problem, because nearly every component out there has a "dual" \ interface anyway. )) |
