├── Changes ├── MANIFEST ├── MANIFEST.SKIP ├── META.yml ├── Makefile.PL ├── OLE.xs ├── README ├── ToDo ├── browser ├── Browser.htm ├── Browser.html ├── Class.png ├── Const.png ├── Default.png ├── Enum.png ├── Event.png ├── Function.png ├── Global.png ├── Help.png ├── Library.png ├── Module.png ├── Property.png └── Type.png ├── eg ├── constants.pl ├── properties.pl ├── tpj.pl ├── typelibs.pl ├── word2pod.pl └── word2xxx.pl ├── hints └── cygwin.pl ├── lib ├── OLE.pm └── Win32 │ ├── OLE.pm │ └── OLE │ ├── Const.pm │ ├── Enum.pm │ ├── Lite.pm │ ├── NEWS.pod │ ├── NLS.pm │ ├── TPJ.pod │ ├── TypeInfo.pm │ └── Variant.pm └── t ├── 1_nls.t ├── 2_variant.t ├── 3_ole.t ├── 4_compat.t ├── 5_unicode.t ├── 6_event.t ├── 7_overload.t └── pod.t /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Win32::OLE. 2 | 3 | Changes in version 0.01-0.03 are by Gurusamy Sarathy. All other changes 4 | are by Jan Dubois unless attributed otherwise. 5 | 6 | 0.1713 April, 2nd 2021 7 | - Make the code compatible with NO_MATHOMS. 8 | Thanks to Danial Dragan [RT #100554]. 9 | 10 | - Allow default event sources that don't start with an alpha character. 11 | Thanks to ernest@eis.ru [rt #43574] 12 | 13 | - Declare TPJ.pod charset as latin1, run Test::Pod over all pods. 14 | Thanks to Alan Berndt [PR#5] 15 | 16 | - Fix compilation on cygwin. 17 | Thanks to BinGOs [PR#6]. 18 | Also thanks to Paulo Custodio for providing an alternate patch [PR#8]. 19 | 20 | - Make Win32::OLE::Const work with Win64. 21 | Thanks to Takuto Naito [PR#9]. 22 | 23 | - Make code pass under -Werror=format-security. 24 | Thanks to David Dyck [PR#11]. 25 | 26 | - Adjust t/ole.t test 27 because DATE_LONGDATE no longer seems 27 | to emit a leading 0 for single-digit day numbers. 28 | 29 | 0.1712 May, 14th 2014 30 | - Make OLE.xs compatible with 64-bit Cygwin. Thanks to 31 | Alexander Stadler [RT #95612] 32 | 33 | 0.1711 December, 11th 2013 34 | - remove EUMM-Update changes to Makefile.PL, which removed 35 | the updated metadata in 0.1710 from META.yml 36 | 37 | 0.1710 December, 4th 2013 38 | - Speedup Win32::OLE::Const by avoiding unneccessary calls to 39 | stat(). Thanks to Eric Roode. 40 | - Skip ANSI <-> OEM conversion test unless the OEM code page 41 | is 437 or 850 [RT #53704] 42 | - Fix required perl version 5.6 -> 5.006. 43 | - Add Github repo link to META.yml 44 | - Typo fixes by David Steinbrunner 45 | - Avoid 5.18 bug in t/3_ole.t about AUTOLOAD inheritance failure 46 | using SUPER:: [perl #120694] 47 | 48 | 0.1709 April 17th 2008 49 | - Get rid of "package Win32" statement in lib/OLE.pm because 50 | it confuses the CPAN indexer. 51 | 52 | 0.1708 April 17th 2008 53 | - new version for separate upload to CPAN 54 | - updated email addresses 55 | - simplified Makefile.PL 56 | - added META.yml 57 | - additional casts to suppress compiler warnings under Win64 58 | - added V_RECORD() and V_RECORDINFO macros for MinGW 59 | - changed code to be conformant with ISO for() variable scoping rules 60 | 61 | 0.1707 unreleased, August 7th 2006 62 | - add special support for tlbinf32.dll from Microsoft 63 | 64 | 0.1706 unreleased, June 8th 2006 65 | - add support for receiving VT_RECORD and arrays of VT_RECORD 66 | - improve error handling logic 67 | 68 | 0.1705 unreleased, March 28th 2006 69 | - fix memory leak in Win32::OLE::Enum::All() and Win32::OLE::Enum::Next() 70 | (as a side effect collections containing undefined elements, 71 | like VT_NULL or VT_EMPTY variant, will be handled correctly) 72 | 73 | 0.1704 unreleased, November 28th 2005 74 | - in ClearVariantObject() check IDispatch/IUnknown variants 75 | for NULL before calling Release() on them 76 | - Win32::OLE::Const: check for 32 bit typelibs even in Win64 mode 77 | - Don't load hidden or restricted types in Win32::OLE::Const. 78 | This fixes the "emptyenum redefined" problem with the "Microsoft 79 | Word" type library. 80 | 81 | 0.1703 September 6th 2005 82 | - remove all USING_WIDE() codepaths 83 | - use PTR2IV() and INT2PTR() macros 84 | - make everything work with current cygwin 85 | 86 | 0.1702 unreleased, Sun, September 5th 2004 87 | - fix freeing of VT_BYREF Win32::OLE::Variant objects 88 | 89 | 0.1701 unreleased, Thu, August 28th 2003 90 | - add Win32::OLE->Option(Variant => 1) support 91 | 92 | 0.17 Mon, August 11th 2003 93 | - add IsNothing and IsNullString predicate methods to 94 | Win32::OLE::Variant 95 | - nullstring() variants used to be converted to undef. They 96 | are now converted to the empty string. 97 | 98 | 0.1604 unreleased, Thu, July 22nd 2003 99 | - fix passing nullstring() as a parameter. VariantCopy() used 100 | to turn it back into an empty string. 101 | 102 | 0.1603 unreleased, Thu, March 4th 2003 103 | - fix PL_dowarn test to only check the relevant bit 104 | 105 | 0.1602 unreleased, Thu, February 13th 2003 106 | - Work around a Perl problem to support lvalue arguments to OLE 107 | method calls (e.g. substr() expressions). This will only work 108 | for PV lvalues, and not for IV lvalues (like pos()). 109 | 110 | 0.1601 Fri, November 22nd, 2002 111 | - allow Variant(VT_VARIANT|VT_BYREF) as a shortcut for 112 | Variant(VT_VARIANT|VT_BYREF, Variant(VT_EMPTY)) 113 | 114 | 0.16 Fri, October 18th, 2002 115 | - Add Unicode support: passing Unicode strings to methods and 116 | properties as well as returning Unicode back to Perl works now 117 | - Unicode::String objects can be passed to methods or assigned 118 | to properties 119 | - Make Unicode support compatible with Perl 5.8 120 | - Remove prototype checking from Win32::OLE::Forward() so that 121 | it works normally as an automation method too 122 | - Fix compatibility problem ($AUTOLOAD munging) with Devel::DProf 123 | - Add Win32::OLE::nullstring() method [alias for Variant(VT_BSTR)] 124 | - Fix 2_variant.t tests for non-US locales 125 | - Fix 3_ole.t test to not require write access to HKCR registry 126 | 127 | 0.1502 September, 7th 2001 128 | - Only turn undef into VT_ERROR/DISP_E_PARAMNOTFOUND when used as a 129 | positional parameter in a method call. Otherwise turn it into 130 | VT_EMPTY. 131 | 132 | 0.1501 February, 6th 2001 133 | - Don't clobber $1 etc. in AUTOLOAD. Unfortunately Perl doesn't set 134 | POK on the $1 SV, so we still cannot pass it to OLE methods. :( 135 | 136 | 0.15 Wed, December 6th, 2000 137 | - Make sure the OLE browser works with IE5.5 and the latest ActivePerl 138 | - Relax the checks for file existance in Win32::OLE::Const 139 | 140 | 0.1403 Tue, November 21st, 2000 141 | - Win32::OLE::Const: ignore non-existant typelibs (by Richard Letts) 142 | - safeguard against access violation in Dispatch() 143 | - Work around perl_call_sv() bug in ReportOleError(); use G_EVAL and 144 | rethrow the exception to get the runlevel right 145 | 146 | 0.1402 Mon, September 25th, 2000 147 | - Fix potential crash during global cleanup when _Unique is set 148 | (by Rudi Farkas ) 149 | 150 | 0.1401 Mon, September 11th, 2000 151 | - fix bug in GetMultiByteEx() sometimes chopping off the last byte 152 | 153 | 0.14 Tue, August 22th, 2000 154 | - remove support for Perl 5.004 & 5.005 155 | - don't built for 5.005 Threads (because it won't work anyways) 156 | - make sure the other compile options for 5.6 work 157 | - support embedded '\0's in BSTR return values 158 | 159 | 0.1301 Thur, July 13th, 2000 (dougl@ActiveState.com) 160 | - patch to fix exported functions 161 | - lost UTF-8 support added back in 162 | 163 | 0.13 Sat, May 6th, 2000 164 | - add Win32::OLE::Variant::nothing() function 165 | - fix strrev() definition for Borland 166 | - changes based on ideas and patches from Rudi Farkas 167 | : 168 | - add _Unique option to prevent creating duplicate proxy Win32::OLE 169 | objects for the same COM object 170 | - add _NewEnum option to add a visible _NewEnum property to 171 | collection objects. 172 | 173 | 0.12 Thu, April 13th, 2000 174 | - remove call to CoFreeUnusedLibraries from ReleasePerlObject 175 | - added Win32::OLE->FreeUnusedLibraries() class method 176 | - fix Variant->Put() support for SAFEARRAYs of BSTR/DISPATCH/UNKNOWN 177 | - fix error message: "argument %" for Invoke was of by one 178 | - support setting Warn option to CODE reference 179 | (suggested by Tobias Martinsson ) 180 | - TPJ article added 181 | - add CYGWIN support (by Eric Fifer ) 182 | - changed handling of VT_DATE and VT_ERROR Variants to return a 183 | Win32::OLE::Variant object (by Eric Fifer) 184 | 185 | 0.1101 libwin32-0.15 / ActivePerl build 520 186 | - VarAdd() etc. temporarily removed for VC++ 5.0 compatibility 187 | 188 | 0.11 on CPAN 189 | - reorganization of Win32::OLE::Type* packages 190 | - Win32::OLE::Const now uses Win32::OLE::Type* packages 191 | - Win32::OLE::Const now uses LoadTypeLibEx to avoid registering 192 | type libraries accidendly 193 | - Win32::OLE::Const: EnumTypeLibs() and LoadRegTypeLib() methods 194 | - new DHTML typelib browser 195 | - new Win32::OLE::GetTypeInfo() method 196 | - Forwarder objects 197 | 198 | 0.1010 (unreleased) 199 | - support $obj = CreateObject Win32::OLE 'My.App'; 200 | - event dispatch by dispid instead of by name 201 | (for controls not providing type information) 202 | - allow "empty" Variant(VT_DISPATCH) 203 | - misc fixes for VT_BYREF Variants 204 | 205 | 0.1009 (unreleased) 206 | - Additional Variant overloads: Add, Sub, Mul, Div 207 | - some additional variant conversion error checking 208 | - VT_DECIMAL support 209 | 210 | 0.1008 ActivePerl 517 211 | - new LetProperty() method 212 | - new COINIT_NO_INITIALIZE mode 213 | - new HRESULT() function 214 | - bug fix: SetProperty (incl. hash syntax) now uses PROPERTYPUTREF to 215 | assign a VT_BYREF | VT_DISPATCH object 216 | 217 | 0.1007 Sun, April 25th, 1999 218 | - patches from ActiveState for sample code in OLE.pm POD section 219 | - Win32::OLE::Const now correctly treats version numbers as hex 220 | - use SvPV_nolen() where appropriate 221 | - Win32::OLE::NLS methods: SetLocaleInfo, SendSettingChange 222 | - Win32::OLE::Variant::Put returns $self for chaining 223 | - Win32::OLE::Variant::Put(ARRAYREF) implemented 224 | - Win32::OLE->WithEvents() function 225 | - new Win32::OLE::Variant methods: Currency/Date/Number/Time 226 | - AssignVariantFromSV() fixes for locale related VT_DATE/VT_CY problems 227 | - Win32::OLE::Variant::Get/Put fixed for VARIANT|BYREF pointing to ARRAY 228 | - several robustness enhancements to compensate for Perl's indeterminate 229 | sequence of global object destruction 230 | - Win32::OLE->EnumAllObjects() function 231 | - t/6_event.t tests for WithEvents functionality 232 | - DCOM support in Win32::OLE->new() finally documented 233 | - GetObject and GetActiveObject now support optional DESTROY argument 234 | - OVERLOAD now works in DESTRUCTOR callback too 235 | - new file NEWS.pod describes user visible changes 236 | 237 | 0.1006 (unreleased) 238 | - replace many XSRETURN_UNDEFs by XSRETURN_EMPTY 239 | - various TypeInfo/TypeLib changes; Win32::OLE::GetTypeInfo() added 240 | - trial implementation of Win32::OLE::QueryInterface 241 | 242 | 0.1005 PRK update, ActivePerl 509 243 | - rearrange PL_* definitions for 5.004_05 compatibility 244 | - dependency on Win32::Registry removed. Win32::OLE::Const now uses XS 245 | code to search the registry. Now only needs read access to registry. 246 | Also reads the registry only once and caches typelibrary information. 247 | - Win32::OLE->GetActiveObject() and Win32::OLE->GetObject() methods now 248 | also support an optional destructor as a 2nd argument. 249 | - Export SetSVFromVariantEx from DLL too. Change SetSVFromVariant() to 250 | call SetSVFromVariantEx(..., bByRefObj=FALSE) instead of TRUE. 251 | - removed Typeinfo.pm from Makefile.PL/MANIFEST before sending to AS. 252 | 253 | 0.1004 (unreleased) 254 | - SetVariantFromSV calls VariantClear instead of VariantInit 255 | - new Win32::OLE::Variant $object->Copy() method 256 | - new Win32::OLE->Option() class method for CP/LCID/Warn access 257 | - removed COINIT_ALREADYINITIALIZED and __DisableOleInit 258 | - Win32::OLE::Variant->LastError added for backward compatibility 259 | (it's now just a proxy for Win32::OLE->LastError) 260 | 261 | 0.1003 (included with ActivePerl 507) 262 | - Win32::OLE::Variant: Support for SAFEARRAYs (VT_ARRAY) added 263 | New methods: Dim/Get/Put 264 | - SetSVFromVariantEx() can optionaly convert VT_BYREF variants to 265 | Win32::OLE::Variant objects instead of simply dereferencing them 266 | - Win32::OLE::Variant "shares" class variables with Win32::OLE now 267 | - Initialize/Uninitialize/SpinMessageLoop reset LastError 268 | - EXPERIMENTAL ITypeInfo stuff 269 | - CP_MACCP, CP_UTF7, CP_UTF8 constants in OLE.pm 270 | - Win32::OLE::Enum::All converted to XS code. Enum.pm is now just POD 271 | - New Win32::OLE::Lite module which requires *no* additional modules 272 | - New COINIT_ALREADYINITIALIZED mode (and Win32::OLE::__DisableOleInit 273 | constant) to disable COM initialization by Win32::OLE 274 | - {Ole|Co}Uninitialize() no longer called when the corresponding 275 | Initialize didn't succeed 276 | 277 | 0.1002 (released by ActiveState with ActivePerl builds 505 and 506) 278 | - contains Win32::OLE::__DisableOleInit stuff ??? 279 | 280 | 0.1001 (unreleased) 281 | - No longer needs XSLock(); all C functions now receive a pPerl pointer 282 | - Some functions exported for use by embedders (PerlSE, PerlCOM) 283 | - PPD entries added into Makefile.PL 284 | 285 | 0.10 Thu Sep 10 17:32:16 1998 (libwin32-0.14) 286 | - memory corruption fix (for ->SetProperty method) by Gurusamy Sarathy 287 | - document *nitialize(), SpinMessageLoop() 288 | 289 | 0.0902 (unreleased) 290 | - Allow specification of apartment model to Initialize() method. Special 291 | case is COINIT_OLEINITIALIZE to fall back to OleInitialize(). This 292 | is required to instantiate objects using compound document technology, 293 | like e.g. "MAPI.Session". 294 | - Compatibility module now uses OleInitilize() 295 | 296 | 0.0901 (unreleased) 297 | - PL_na replaced by local variables 298 | - Dispatch method now accepts [wFlags, 'method'] to specify 299 | various dispatch flags, e.g. DISPATCH_PROPERTYPUT 300 | - new $Obj->SetProperty() methods supports setting properties 301 | with parameters 302 | - bug fix: the DCOM spec ['host', 'prog.id'] is no longer 'shifted' 303 | - more doc tweaks 304 | 305 | 0.09 (unreleased) 306 | - fix conversion from VT_DISPATCH/VT_UNKNOWN Win32::OLE::Variant objects 307 | into Win32::OLE objects (were previously blessed into wrong class) 308 | - dynamically load CoInitializeEx to make OLE.dll compatible with 309 | "Win95 without DCOM" once again 310 | - convert Perl globals to PL_xxx form (with defines for Perl 5.004_xx) 311 | - minor doc tweaks 312 | - call CoFreeUnusedLibraries() whenever an OLE object is released 313 | 314 | 0.0810 (unreleased, maybe PRK for Win32 version, included by ActivePerl 501) 315 | - Removed USE_SV_PERINTERP, perl_atexit() only used for 5.004_68 and up 316 | 317 | 0.0809 (unreleased) identical to 0.0808 318 | 319 | 0.0808 (unreleased) 320 | - Introduced USE_SV_PERINTERP to switch off perl_atexit() usage 321 | 322 | 0.0807 (unreleased) 323 | - OleInitialize replaced by CoInitializeEx(NULL, COINIT_MULTITHREADED) 324 | (as suggested by James Snyder). This gets rid of the hidden top-level 325 | window problem. 326 | - Fixed warning in Win32::OLE::Const when called without arg 327 | 328 | 0.0806 (unreleased) 329 | - Bug fixes for IsLocalMachine() 330 | - Free per-interpreter memory area at interpreter-exit 331 | - Bootstrap no longer static function 332 | - Use MY_VERSION as key/variable name for per-interpreter data 333 | 334 | 0.0805 (unreleased) 335 | - Never do CLSID lookup by registry on local machine 336 | - try to use socket APIs too to determine host identity 337 | - make all globals per-interpreter variables / remove DllMain 338 | - proper per-interpreter cleanup for all Perl versions 339 | 340 | 0.0804 (unreleased) 341 | - Fix breakage in GetOleObject (from 0.0801) for 5.004_04 and earlier 342 | - Ignore DCOM hostname if it seems to be the local machine 343 | 344 | 0.0803 (unreleased) 345 | - Rearrange t/3_ole.t to behave nicely when Excel is not installed 346 | - Win32::OLE->Dispatch: only warn about unidentifiable method name 347 | when C is in effect (kind of) 348 | - Most error msgs and warnings are prefixed with Win32::OLE version# 349 | 350 | 0.0802 (unreleased) 351 | - Win32::OLE->new(['Machine', 'Prog.Id']) does a remote registry lookup 352 | if the Prog.Id is not registered locally. 353 | - CLSCTX changed to CLSCTX_REMOTE_SERVER when a machine is specified. 354 | Otherwise OLE would still prefer a local server when available 355 | 356 | 0.0801 (unreleased) 357 | - Win32::OLE::Tie::(FETCH|STORE) now interpret $^H correctly 358 | - removed all Perl related stuff from DllMain (for embedded stuff) 359 | - Additional checks in GetOleObject for Perl 5.004_05 or later 360 | 361 | 0.08 Mon May 11 03:36:49 1998 362 | - Make sure mg_get() gets called during GetOleObject() 363 | 364 | 0.0615 (unreleased) 365 | - use SvIMMORTAL instead of SvREADONLY where applicable 366 | - use newCONSTSUB in Win32::OLE::Const to define inlineable functions 367 | 368 | 0.0614 (unreleased) 369 | - devel/dumprot.cpp removed, use IROTVIEW instead :-) 370 | - COSERVERINFO hack removed, requires MSC++ 4.2b or later now 371 | 372 | 0.0613 (unreleased) 373 | - WinOleEnum objects where never Safefree()d before 374 | - New Initialize/Uninitialize class methods. Uninitialize zombifies all 375 | OLE objects and then calls OleUninitialize. 376 | 377 | 0.0612 (unreleased) 378 | - new Win32::OLE->SpinMessageLoop() class method 379 | - Messageloop will be emptied before OleUnitialize is called 380 | (thanks to Steve Glassman for finding this problem!) 381 | 382 | 0.0611 (unreleased) 383 | - Win32::OLE::Tie::Store use DISPATCH_PROPERTYPUTREF for objects 384 | (as suggested by Steve Biondi) 385 | - all OLE calls now automatically reset LastError 386 | - added devel/dumprot.cpp tool to distribution 387 | 388 | 0.0610 (unreleased) 389 | - Win32::OLE::Const now loads consts from all TKINDs and not only ENUMs 390 | - Win32::OLE::Variants are actually freed during DESTROY now 391 | - Misc. robustness fixes (VariantClear etc.) 392 | 393 | 0.0609 (unreleased) 394 | - Win32::OLE::LastError() returns $Win32::OLE::LastError 395 | - misc COSERVERINFO fixes 396 | 397 | 0.0608 (unreleased) 398 | - use scode from excepinfo structure when available instead 399 | of DISP_E_EXCEPTION (as suggested by Steve Glassman) 400 | - misc. Get(WideChar|MultiByte) robustness enhancements 401 | - Win32::OLE::new now uses CLSTLX_SERVER 402 | - " allows specification of remote server name 403 | - " " " of numeric class id 404 | 405 | 0.0607 (unreleased) 406 | - enhanced C allows multiple args and supports array refs too 407 | - SetSVFromVariant array bug fixes 408 | 409 | 0.0606 (unreleased) 410 | - use SvTRUE instead of SvIV to convert SV to VARIANT 411 | - REFCNT of returned SV for VT_ARRAY variant is now set correctly 412 | - SAFEARRAYs of VT_DISPATCH and VT_BSTR (and VT_VARIANT containing 413 | those) are now handled correctly 414 | - folding of SAFEARRAYs removed again. Original structure is maintained 415 | t/3_ole.t adjusted accordingly 416 | - Win32::OLE::Enum->All doesn't call Reset anymore 417 | 418 | 0.0605 (unreleased) 419 | - Property enumeration now dereferences TKIND_COCLASS etc. 420 | - Overloading in Win32::OLE now only enabled by OVERLOAD pseudotarget 421 | - Win32::OLE::CreateObject function for compatibility w/"Learning Perl" 422 | - Win32::OLE->LastError returns a dual value now (IV and PV) 423 | - Removed unsupported TKIND_ and VT_ constants from Win32::OLE::Variant 424 | - lcidDefault changed back to LOCALE_SYSTEM_DEFAULT, the language 425 | neutral setting didn't allow portable scripts either 426 | - Sample file type converter script in eg/word2xxx.pl 427 | - valof uses CP and LCID of arg class for variant conversion 428 | 429 | 0.0604 (unreleased) 430 | - New package variable Win32::OLE::Tie specifies 'Win32::OLE::Tie' class 431 | - Win32::OLE::Tie FIRSTENUM/NEXTENUM added for compatibility mode 432 | - Win32::OLE::Tie STORE/FETCH renamed. Added default method argument 433 | - Default method retries enabled under C only 434 | - New C function; C renamed to C 435 | - Const module now defines xlConstant instead of $xlConstant 436 | - multi-dimensional arrays are folded to lower dimensions if possible 437 | (e.g. 1x1 array -> scalar, 1x5 array -> list of 5, 5x1 -> unchanged) 438 | - new regression tests: unicode, variant 439 | - new sample: eg/word2pod.pl 440 | - first cut of NLS.pm module 441 | - compiles and tests ok with 5.004_60 built with -DUSE_THREADS 442 | - new C function 443 | - Win32::OLE objects overloaded conversion to strings and numbers 444 | 445 | 0.0603 (unreleased) 446 | - Win32::OLE::Enum::Count method removed 447 | - SetSVFromVariant now works with SAFEARRAYs of non-VARIANT types too 448 | - Onedimensional SAFEARRAY of UI1s converted to SvPV 449 | - OLE, Enum and Variant objects all linked in g_pObj chain 450 | - g_pObj chain protected by critical section to make it thread safe 451 | - New package variables $CP,$LCID for Win32::OLE and Win32::OLE::Variant 452 | - default lcid changed from LOCALE_SYSTEM_DEFAULT -> language neutral 453 | - LastOleError is stored in a package variable $LastError now 454 | - Error reporting now controled by $Warn package variable 455 | - Win32::OLE::Variant: new As,ChangeType,Type,Unicode,Value methods 456 | - Win32::OLE::Variant overloaded "" and 0+ operations 457 | - Preliminary Variant BYREF support 458 | - Dispatch can return Win32::OLE::Variant objects too 459 | - Compatibility package "OLE" created 460 | - Invoke method added, supports default method too 461 | - Memory leaks 462 | - "keys %$object", QueryObjectType and Win32::OLE::Const::Load no 463 | longer croak when the GetTypeInfo is unavailable or returns 0 464 | - Enum::new returns undef if object is not a valid collection object 465 | 466 | 0.06 Fri Feb 6 21:13:20 1998 467 | - bugfix: DoCroak uninitialized variable 468 | - Multidimensional arrays can now be sent and received 469 | 470 | 0.05 Sun Dec 14 21:13:11 1997 471 | - All OLE errors are caught and a verbose error message is provided 472 | through Carp::croak (if -w is in effect) 473 | - Internal errors will no longer be silently ignored; they'll croak now 474 | - All hardcoded buffer size limits removed from XS code 475 | - Collection support is fixed and moved into Win32::OLE::Enum 476 | - C now enumerates the objects properties 477 | - Win32::OLE::Const module imports constants from type libraries 478 | - Moniker support through Win32::OLE->GetObject 479 | - Win32::OLE->GetActiveObject finds active instance of OLE server 480 | - Variants moved to Win32::OLE::Variant module; enhanced functionality 481 | - Win32::OLE->QueryObjectType return typelib name and class name of 482 | object 483 | 484 | 0.04 Sun Oct 12 23:03:32 1997 (unreleased) 485 | - support for unnamed default methods (thanks to 486 | Doug Lankshear ) 487 | - CreateVariantFromSV is more robust now 488 | - support for omitting optional params with "undef" 489 | - named arguments can be specified as a hash ref 490 | - array elements are now properly typed (used to be always text) 491 | - additions to testsuite 492 | - With() utility method suggestion 493 | - optional DESTROY method arg for Win32::OLE->new 494 | - Win32::OLE::CreateObject renamed to Win32::OLE::new 495 | old Perl new() method deleted 496 | - Hardcoded package names gone, so inheritance is feasible now 497 | 498 | 0.03 Sat Jul 12 16:10:07 1997 499 | - DllEntryPoint for Borland 500 | 501 | 0.02 Sat May 10 15:40:52 1997 502 | - cleaned up one big memory leakathon (DESTROY actually gets 503 | called now on all the objects) 504 | - back to XS 505 | - package names are Win32::OLE and Win32::OLE::Tie now 506 | - fixed misplaced DESTROY 507 | - implemented OLEUninitialize via DllMain 508 | 509 | 0.01 Sat Apr 5 14:23:42 1997 510 | - original version; created by h2xs 1.18 511 | - imported Activeware version 512 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes Lowlevel changelog 2 | MANIFEST 3 | MANIFEST.SKIP 4 | META.yml 5 | Makefile.PL 6 | OLE.xs 7 | README 8 | ToDo 9 | hints/cygwin.pl 10 | lib/OLE.pm Compatibility layer: old toplevel OLE.pm 11 | lib/Win32/OLE.pm 12 | lib/Win32/OLE/Const.pm Win32::OLE::Const module: TypeLib constants 13 | lib/Win32/OLE/Enum.pm Win32::OLE::Enum module: Collection objects 14 | lib/Win32/OLE/Lite.pm Lightweight OLE.pm not using ANY other modules 15 | lib/Win32/OLE/NEWS.pod History of user visable changes 16 | lib/Win32/OLE/NLS.pm Win32::OLE::NLS module: National Language Support 17 | lib/Win32/OLE/TPJ.pod Win32::OLE article from "The Perl Journal" #10 18 | lib/Win32/OLE/TypeInfo.pm Win32::OLE::TypeInfo module 19 | lib/Win32/OLE/Variant.pm Win32::OLE::Variant module: VARIANT variables 20 | 21 | browser/Browser.htm OLE Automation type library browser 22 | browser/Browser.html FRAMESET document for typelib browser 23 | 24 | browser/Class.png 25 | browser/Const.png 26 | browser/Default.png 27 | browser/Enum.png 28 | browser/Event.png 29 | browser/Function.png 30 | browser/Global.png 31 | browser/Help.png 32 | browser/Library.png 33 | browser/Module.png 34 | browser/Property.png 35 | browser/Type.png 36 | 37 | eg/constants.pl Sample script prints all Excel defined constants 38 | eg/properties.pl Sample script prints all Excel application properties 39 | eg/tpj.pl Sample code from the Win32::OLE article in TPJ #10 40 | eg/typelibs.pl Sample script prints all registered typelib names 41 | eg/word2pod.pl Prototype of a Word -> POD translator 42 | eg/word2xxx.pl Sample file type converter 43 | 44 | t/1_nls.t Regression tests for Win32::OLE::NLS module 45 | t/2_variant.t Regression tests for the Win32::OLE::Variant module 46 | t/3_ole.t Regression tests for Win32::OLE using Excel 7 and above 47 | t/4_compat.t Regression tests for OLE compatibility module 48 | t/5_unicode.t Regression tests using the Unicode::String module 49 | t/6_event.t Regression tests for OLE Events using Excel 50 | t/7_overload.t Regression tests for overloaded number/string conversion 51 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | [#~]$ 2 | \.bak$ 3 | \.tar\.gz$ 4 | \.xls$ 5 | \.zip$ 6 | \bblib/ 7 | \bdevel/ 8 | \bmisc/ 9 | \btarballs/ 10 | \bMakefile\b 11 | .svn/ 12 | -------------------------------------------------------------------------------- /META.yml: -------------------------------------------------------------------------------- 1 | --- #YAML:1.0 2 | name: Win32-OLE 3 | abstract: OLE Automation extensions 4 | version: 0.1713 5 | author: 6 | - Jan Dubois 7 | license: perl 8 | requires: 9 | perl: 5.006 10 | resources: 11 | license: http://dev.perl.org/licenses/ 12 | repository: https://github.com/jandubois/win32-ole 13 | meta-spec: 14 | version: 1.3 15 | url: http://module-build.sourceforge.net/META-spec-v1.3.html 16 | generated_by: Jan Dubois 17 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | use Config qw(%Config); 6 | use ExtUtils::MakeMaker qw(&WriteMakefile &neatvalue); 7 | 8 | unless ($^O eq "MSWin32" || $^O eq "cygwin") { 9 | die "OS unsupported\n"; 10 | } 11 | 12 | my $INSTDIR = grep(/INSTALLDIRS=perl/i, @ARGV) ? "lib" : "site\\lib"; 13 | 14 | my %param = 15 | ( 16 | NAME => 'Win32::OLE', 17 | VERSION_FROM => 'lib/Win32/OLE.pm', 18 | XS => { 'OLE.xs' => 'OLE.cpp' }, 19 | # Without the next line MakeMaker will not export the bootstrap function 20 | # (because we are using FUNCLIST too). 21 | DL_FUNCS => { 'Win32::OLE' => [] }, 22 | clean => { FILES => 'test.xls' }, 23 | ); 24 | my $FUNCLIST = [qw(SetSVFromVariant SetSVFromVariantEx SetVariantFromSV CreatePerlObject)]; 25 | $param{FUNCLIST} = $FUNCLIST if eval "$ExtUtils::MakeMaker::VERSION" >= 5.4302; 26 | $param{NO_META} = 1 if eval "$ExtUtils::MakeMaker::VERSION" >= 6.10_03; 27 | WriteMakefile(%param); 28 | 29 | sub MY::xs_c { 30 | ' 31 | .xs.cpp: 32 | $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.cpp 33 | '; 34 | } 35 | 36 | sub MY::dlsyms { 37 | my($self,%attribs) = @_; 38 | 39 | my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; 40 | my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; 41 | my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; 42 | my(@m); 43 | (my $boot = $self->{NAME}) =~ s/:/_/g; 44 | 45 | if (not $self->{SKIPHASH}{'dynamic'}) { 46 | push(@m," 47 | $self->{BASEEXT}.def: Makefile.PL 48 | ", 49 | q! $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Mksymlists \\ 50 | -e "Mksymlists('NAME' => '!, $self->{NAME}, 51 | q!', 'DLBASE' => '!,$self->{DLBASE}, 52 | q!', 'DL_FUNCS' => !,neatvalue($funcs), 53 | q!, 'FUNCLIST' => !,neatvalue($FUNCLIST), 54 | q!, 'IMPORTS' => !,neatvalue($imports), 55 | q!, 'DL_VARS' => !, neatvalue($vars), q!);" 56 | !); 57 | } 58 | join('',@m); 59 | } 60 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | The Win32::OLE module provides OLE Automation capabilities to Perl. 2 | It is based on the OLE module distributed by ActiveState with 3 | their "Perl for Win32" port of Perl 5.003_07. Win32::OLE replaces 4 | the older OLE module, which is now considered obsolete. Win32::OLE 5 | is already included in the ActivePerl binary distribution. 6 | 7 | This module is compatible with Perl 5.004_01 and above. Compilation 8 | requires either Microsoft Visual C++ 4.2b or later, or Borland C++ 9 | version 4.02 or above. 10 | 11 | Do: 12 | 13 | perl Makefile.PL 14 | $make 15 | $make test 16 | $make install 17 | 18 | where $make is either "nmake" or "dmake". 19 | 20 | See the pod documentation for details of usage. 21 | 22 | The file NEWS.pod contains a history of user visible changes against the 23 | previous version. 24 | 25 | ***WARNING*** This version of the module contains ALPHA level support for 26 | OLE events. This support doesn't work yet for some OLE controls and the 27 | user interface is still subject to change! 28 | -------------------------------------------------------------------------------- /ToDo: -------------------------------------------------------------------------------- 1 | # The following items WILL BE done in the near future :-) 2 | 3 | - There is a possible memory leak in Win32::OLE::Const::_Load when 4 | this function croaks (because $Warn is set to 3) and the croak 5 | is catched in a __DIE__ handler. 6 | 7 | # This file contains random thoughts and notes about what might be 8 | # changed in future versions of Win32::OLE. 9 | # Note: No particular order, no promises! 10 | 11 | - Test suite: 12 | Enum 13 | Compatibility module 14 | PUTPROPERTY using "unnamed" method ???? 15 | 16 | - Provide access to instance data for subclassing. 17 | Win32::OLE objects use the tied hash mechanism for set/getproperty, 18 | so the standard way of accessing instance data is not available. 19 | 20 | - Call SUBCLASS::__new__ for internally created objects, so that the subclass 21 | can do additional initialisation? Function name? 22 | 23 | - TypeInfo support 24 | - Generic Typelib stuff 25 | - Validate method/property parameters 26 | - Automatically assign new OLE objects to a subclass, if that 27 | namespace exists and it "isa" Win32::OLE subclass. 28 | (e.g. automaticall assign all Excel chart objects to Excel::Chart) 29 | 30 | - Better error messages 31 | Use Grahams Error.pm module when it has been accepted by p5p. 32 | 33 | - Implement an error API that offers control over exceptional conditions 34 | (rather than simply croak()ing, which is considered "bad" for modules) 35 | Perhaps this can ride over a standard Exception package when it becomes 36 | available. 37 | 38 | - Caching of method dispids should be done on class basis, not per object. 39 | 40 | - Make OLE.xs thread-safe 41 | 42 | - Provide support for OLE events, if possible 43 | - Callbacks in a separate thread 44 | - Through some kind of event loop 45 | -------------------------------------------------------------------------------- /browser/Browser.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Internet Explorer could not load the PerlScript engine. This is most 5 | likely due to the value of the "Initialize and script ActiveX 6 | controls not marked as safe" security setting of the "Local 7 | intranet" zone. PerlScript inside IE will only run on Windows XP 8 | SP2 and later if this setting is set to Enable. Setting it to 9 | Prompt doesn't seem to work. 10 | 11 | 12 | 45 | 46 | 684 | 685 | 686 | -------------------------------------------------------------------------------- /browser/Browser.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Win32::OLE - Type Library Browser 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | <H1>Sorry</H1> 16 | <H3>this application only works with Internet Explorer.</H3> 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /browser/Class.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Class.png -------------------------------------------------------------------------------- /browser/Const.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Const.png -------------------------------------------------------------------------------- /browser/Default.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Default.png -------------------------------------------------------------------------------- /browser/Enum.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Enum.png -------------------------------------------------------------------------------- /browser/Event.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Event.png -------------------------------------------------------------------------------- /browser/Function.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Function.png -------------------------------------------------------------------------------- /browser/Global.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Global.png -------------------------------------------------------------------------------- /browser/Help.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Help.png -------------------------------------------------------------------------------- /browser/Library.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Library.png -------------------------------------------------------------------------------- /browser/Module.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Module.png -------------------------------------------------------------------------------- /browser/Property.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Property.png -------------------------------------------------------------------------------- /browser/Type.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/browser/Type.png -------------------------------------------------------------------------------- /eg/constants.pl: -------------------------------------------------------------------------------- 1 | # Print out all constants from the Microsoft Excel type library 2 | 3 | use strict; 4 | use Win32::OLE; 5 | use Win32::OLE::Const; 6 | 7 | my $xl = Win32::OLE::Const->Load("Microsoft Excel 8.0"); 8 | printf "Excel type library contains %d constants:\n", scalar keys %$xl; 9 | foreach my $Key (sort keys %$xl) { 10 | print "$Key = $xl->{$Key}\n"; 11 | } 12 | -------------------------------------------------------------------------------- /eg/properties.pl: -------------------------------------------------------------------------------- 1 | # Print out all Microsoft Excel application properties 2 | 3 | use strict; 4 | use Win32::OLE; 5 | $Win32::OLE::Warn = 3; 6 | 7 | my $Excel = Win32::OLE->new('Excel.Application', 'Quit'); 8 | # Add a workbook to get some more property values defined 9 | $Excel->Workbooks->Add; 10 | print "Excel application properties:\n"; 11 | foreach my $Key (sort keys %$Excel) { 12 | my $Value; 13 | eval {$Value = $Excel->{$Key} }; 14 | $Value = "***Exception***" if $@; 15 | $Value = "" unless defined $Value; 16 | $Value = '['.Win32::OLE->QueryObjectType($Value).']' 17 | if UNIVERSAL::isa($Value,'Win32::OLE'); 18 | $Value = '('.join(',',@$Value).')' if ref $Value eq 'ARRAY'; 19 | printf "%s %s %s\n", $Key, '.' x (25-length($Key)), $Value; 20 | } 21 | -------------------------------------------------------------------------------- /eg/tpj.pl: -------------------------------------------------------------------------------- 1 | # Sample code from the Win32::OLE article in "The Perl Journal" #10 2 | 3 | use strict; 4 | $| = 1; 5 | 6 | my $Contract = 'us8m'; 7 | my $text; 8 | if (1) { 9 | # Offline debugging 10 | $text = `cat tsf$Contract.htm`; 11 | } 12 | else { 13 | use LWP::Simple; 14 | my $URL = 'http://www.cbot.com/mplex/quotes/tsfut'; 15 | $text = get("$URL/tsf$Contract.htm"); 16 | } 17 | 18 | my ($Day,$Time,$hhmm,$Open,$High,$Low,$Close,@Bars); 19 | foreach (split "\n", $text) { 20 | my ($Date,$Price,$Hour,$Min,$Sec,$Ind) = 21 | # 03/12/1998 US 98Mar 12116 15:28:34 Open 22 | m|^\s*(\d+/\d+/\d+) # " 03/12/1998" 23 | \s+US\s+\S+\s+(\d+) # " US 98Mar 12116" 24 | \s+(\d+):(\d+):(\d+) # " 12:42:40" 25 | \s*(.*)$|x; # " Ask" 26 | next unless defined $Date; 27 | $Day = $Date; 28 | 29 | # Convert from implied fractional to decimal format 30 | $Price = int($Price/100) + ($Price%100)/32; 31 | # Round up time to next multiple of 15 minutes 32 | my $NewTime = int(($Sec+$Min*60+$Hour*3600)/900+1)*900; 33 | if (!defined $Time || $NewTime != $Time) { 34 | push @Bars, [$hhmm, $Open, $High, $Low, $Close] 35 | if defined $Time; 36 | $Open = $High = $Low = $Close = undef; 37 | $Time = $NewTime; 38 | my $Hour = int($Time/3600); 39 | $hhmm = sprintf "%02d:%02d", $Hour, $Time/60-$Hour*60; 40 | } 41 | # Update 15 minute bar values 42 | $Close = $Price; 43 | $Open = $Price unless defined $Open; 44 | $High = $Price unless defined $High && $High > $Price; 45 | $Low = $Price unless defined $Low && $Low < $Price; 46 | } 47 | 48 | die "No Times & Sales data found" unless defined $Time; 49 | push @Bars, [$hhmm, $Open, $High, $Low, $Close]; 50 | 51 | # Start Excel and create new workbook with a single sheet 52 | use Win32::OLE qw(in valof with); 53 | use Win32::OLE::Const 'Microsoft Excel'; 54 | use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG); 55 | 56 | my $lgid = MAKELANGID(LANG_ENGLISH, SUBLANG_DEFAULT); 57 | $Win32::OLE::LCID = MAKELCID($lgid); 58 | 59 | $Win32::OLE::Warn = 3; 60 | 61 | print "Start Excel\n"; 62 | my $Excel = Win32::OLE->new('Excel.Application', 'Quit'); 63 | $Excel->{SheetsInNewWorkbook} = 1; 64 | my $Book = $Excel->Workbooks->Add; 65 | my $Sheet = $Book->Worksheets(1); 66 | $Sheet->{Name} = 'Candle'; 67 | 68 | # Insert column titles 69 | my $Range = $Sheet->Range("A1:E1"); 70 | $Range->{Value} = [qw(Time Open High Low Close)]; 71 | $Range->Font->{Bold} = 1; 72 | 73 | $Sheet->Columns("A:A")->{NumberFormat} = "h:mm"; 74 | # Open/High/Low/Close to be displayed in 32nds 75 | $Sheet->Columns("B:E")->{NumberFormat} = "# ?/32"; 76 | 77 | # Add 15 minute data to spreadsheet 78 | print "Add data\n"; 79 | $Range = $Sheet->Range(sprintf "A2:E%d", 2+$#Bars); 80 | $Range->{Value} = \@Bars; 81 | 82 | # Create candle stick chart as new object on worksheet 83 | print "Create chart\n"; 84 | $Sheet->Range("A:E")->Select; 85 | my $Chart = $Book->Charts->Add; 86 | $Chart->{ChartType} = xlStockOHLC; 87 | $Chart->Location(xlLocationAsObject, $Sheet->{Name}); 88 | # Excel bug: old $Chart has become invalid now! 89 | $Chart = $Excel->ActiveChart; 90 | 91 | # Add title, remove legend 92 | with($Chart, HasLegend => 0, HasTitle => 1); 93 | $Chart->ChartTitle->Characters->{Text} = "US T-Bond"; 94 | 95 | # Setup daily statistics 96 | $Open = $Bars[0][1]; 97 | $High = $Sheet->Evaluate("MAX(C:C)"); 98 | $Low = $Sheet->Evaluate("MIN(D:D)"); 99 | $Close = $Bars[$#Bars][4]; 100 | 101 | # Change tickmark spacing from decimal to fractional 102 | with($Chart->Axes(xlValue), 103 | HasMajorGridlines => 1, 104 | HasMinorGridlines => 1, 105 | MajorUnit => 1/8, 106 | MinorUnit => 1/16, 107 | MinimumScale => int($Low*16)/16, 108 | MaximumScale => int($High*16+1)/16, 109 | ); 110 | 111 | # Fat candles with only 5% gaps 112 | $Chart->ChartGroups(1)->{GapWidth} = 5; 113 | 114 | sub RGB { 115 | my ($red,$green,$blue) = @_; 116 | return $red | ($green<<8) | ($blue<<16); 117 | } 118 | 119 | # White background with a solid border 120 | $Chart->PlotArea->Border->{LineStyle} = xlContinuous; 121 | $Chart->PlotArea->Border->{Color} = RGB(0,0,0); 122 | $Chart->PlotArea->Interior->{Color} = RGB(255,255,255); 123 | 124 | # Add 1 hour moving average of the Close series 125 | my $MovAvg = $Chart->SeriesCollection(4)->Trendlines 126 | ->Add({Type => xlMovingAvg, Period => 4}); 127 | $MovAvg->Border->{Color} = RGB(255,0,0); 128 | 129 | # Save worbook to file 130 | print "Save workbook\n"; 131 | my $Filename = 'i:\tmp\tpj\data.xls'; 132 | unlink $Filename if -f $Filename; 133 | $Book->SaveAs($Filename); 134 | $Book->Close; 135 | 136 | ############################################################ 137 | print "Start ADO and update database\n"; 138 | use Win32::OLE::Const 'Microsoft ActiveX Data Objects'; 139 | 140 | my $Connection = Win32::OLE->new('ADODB.Connection'); 141 | my $Recordset = Win32::OLE->new('ADODB.Recordset'); 142 | $Connection->Open('T-Bonds'); 143 | 144 | # Open a recordset for table of this contract 145 | { 146 | local $Win32::OLE::Warn = 0; 147 | $Recordset->Open($Contract, $Connection, adOpenKeyset, 148 | adLockOptimistic, adCmdTable); 149 | } 150 | # Create table and index if it doesn't exist yet 151 | if (Win32::OLE->LastError) { 152 | $Connection->Execute(<<"SQL"); 153 | CREATE TABLE $Contract 154 | ( 155 | Day DATETIME, 156 | Open DOUBLE, High DOUBLE, Low DOUBLE, Close DOUBLE 157 | ) 158 | SQL 159 | $Connection->Execute(<<"SQL"); 160 | CREATE INDEX $Contract 161 | ON $Contract (Day) WITH PRIMARY 162 | SQL 163 | $Recordset->Open($Contract, $Connection, adOpenKeyset, 164 | adLockOptimistic, adCmdTable); 165 | } 166 | 167 | # Add new record to table 168 | use Win32::OLE::Variant; 169 | $Win32::OLE::Variant::LCID = $Win32::OLE::LCID; 170 | 171 | my $Fields = [qw(Day Open High Low Close)]; 172 | my $Values = [Variant(VT_DATE, $Day), 173 | $Open, $High, $Low, $Close]; 174 | { 175 | local $Win32::OLE::Warn = 0; 176 | $Recordset->AddNew($Fields, $Values); 177 | } 178 | 179 | # Replace existing record 180 | if (Win32::OLE->LastError) { 181 | $Recordset->CancelUpdate; 182 | $Recordset->Close; 183 | $Recordset->Open(<<"SQL", $Connection, adOpenDynamic); 184 | SELECT * FROM $Contract 185 | WHERE Day = #$Day# 186 | SQL 187 | $Recordset->Update($Fields, $Values); 188 | } 189 | 190 | $Recordset->Close; 191 | $Connection->Close; 192 | 193 | ############################################################ 194 | print "Start Notes and send email\n"; 195 | 196 | sub EMBED_ATTACHMENT {1454;} 197 | 198 | my $Notes = Win32::OLE->new('Notes.NotesSession'); 199 | my $Database = $Notes->GetDatabase('', ''); 200 | $Database->OpenMail; 201 | my $Document = $Database->CreateDocument; 202 | 203 | $Document->{Form} = 'Memo'; 204 | $Document->{SendTo} = ['Jon Orwant ', 205 | 'Jan Dubois ']; 206 | $Document->{Subject} = "US T-Bonds Chart for $Day"; 207 | 208 | my $Body = $Document->CreateRichtextItem('Body'); 209 | $Body->AppendText(<<"EOT"); 210 | I\'ve attached the latest US T-Bond data and chart for $Day. 211 | The daily statistics were: 212 | 213 | \tOpen\t$Open 214 | \tHigh\t$High 215 | \tLow\t$Low 216 | \tClose\t$Close 217 | 218 | Kind regards, 219 | Mary 220 | 221 | EOT 222 | 223 | $Body->EmbedObject(EMBED_ATTACHMENT, '', $Filename); 224 | 225 | #$Document->Send(0); 226 | $Document->Save(0,0); 227 | 228 | print "Done\n"; 229 | 230 | -------------------------------------------------------------------------------- /eg/typelibs.pl: -------------------------------------------------------------------------------- 1 | # Print all registered type library names 2 | # Warn about different classids using the same type library name. 3 | 4 | use strict; 5 | use Win32::Registry; 6 | use vars qw($HKEY_CLASSES_ROOT); 7 | 8 | my %Version; 9 | my ($hTypelib,$hClsid); 10 | $HKEY_CLASSES_ROOT->Create('TypeLib',$hTypelib) 11 | or die "Cannot access HKEY_CLASSES_ROOT\\Typelib"; 12 | my $Clsids = []; 13 | $hTypelib->GetKeys($Clsids); 14 | foreach my $clsid (@$Clsids) { 15 | $hTypelib->Create($clsid,$hClsid); 16 | next unless $hClsid; 17 | my $Versions = []; 18 | $hClsid->GetKeys($Versions); 19 | foreach my $version (@$Versions) { 20 | my $value; 21 | next unless $hClsid->QueryValue($version,$value); 22 | printf "*** Typelib name \"$value\" multiply defined ***\n" 23 | if defined $Version{$value}; 24 | $Version{$value} = join(', ', @$Versions);; 25 | } 26 | $hClsid->Close; 27 | } 28 | $hTypelib->Close; 29 | 30 | foreach my $TypeLib (sort keys %Version) { 31 | printf "%-60s %s\n", $TypeLib, $Version{$TypeLib}; 32 | } 33 | -------------------------------------------------------------------------------- /eg/word2pod.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Text::Wrap; 3 | use Win32::OLE qw(in with); 4 | use Win32::OLE::Const 'Microsoft Word'; 5 | 6 | die "Usage: perl word2pod.pl Documentation.doc" unless @ARGV == 1; 7 | my $File = $ARGV[0]; 8 | $File = Win32::GetCwd() . "/$File" if $File !~ /^(\w:)?[\/\\]/; 9 | die "File $ARGV[0] does not exist" unless -f $File; 10 | 11 | my $Word = Win32::OLE->new('Word.Application', 'Quit') 12 | or die "Couldn't run Word"; 13 | 14 | my $Doc = $Word->Documents->Open($File); 15 | 16 | # Cache the names of various styles 17 | my %Style = ( 18 | Heading1 => $Doc->Styles(wdStyleHeading1)->NameLocal, 19 | Heading2 => $Doc->Styles(wdStyleHeading2)->NameLocal, 20 | List => $Doc->Styles(wdStyleList)->NameLocal, 21 | ListBullet => $Doc->Styles(wdStyleListBullet)->NameLocal, 22 | ListContinue => $Doc->Styles(wdStyleListContinue)->NameLocal, 23 | ListNumber => $Doc->Styles(wdStyleListNumber)->NameLocal, 24 | Normal => $Doc->Styles(wdStyleNormal)->NameLocal, 25 | PlainText => $Doc->Styles(wdStylePlainText)->NameLocal, 26 | ); 27 | 28 | # The following styles will not break list mode 29 | my %ListStyle = map {$_ => 1} @Style{qw(List ListBullet ListContinue 30 | ListNumber PlainText)}; 31 | 32 | # We don't want to encode Bold/Italic/Code in headings or plaintext 33 | foreach my $Style (wdStyleHeading1, wdStyleHeading2, wdStylePlainText) { 34 | with($Doc->Styles($Style)->Font, 35 | Bold => 0, 36 | Italic => 0, 37 | Name => 'Times New Roman', 38 | ); 39 | } 40 | 41 | # Translating the format on a char by char basis is just too slow through OLE. 42 | # We use Words Search-and-Replace feature instead. 43 | my $Search = $Doc->Content->Find; 44 | my $Replace = $Search->Replacement; 45 | 46 | $Search->Font->{Bold} = 1; 47 | $Replace->{Text} = 'B<^&>'; 48 | $Search->Execute({Replace => wdReplaceAll}); 49 | 50 | $Search->Clearformatting; 51 | $Search->Font->{Italic} = 1; 52 | $Replace->{Text} = 'I<^&>'; 53 | $Search->Execute({Replace => wdReplaceAll}); 54 | 55 | $Search->Clearformatting; 56 | $Replace->{Text} = 'C<^&>'; 57 | foreach my $FontName ('Courier', 'Courier New') { 58 | $Search->Font->{Name} = $FontName; 59 | $Search->Execute({Replace => wdReplaceAll}); 60 | } 61 | 62 | my $EmptyLine = 1; 63 | my $ListItem; 64 | 65 | foreach my $Paragraph (in $Doc->Paragraphs) { 66 | my $Style = $Paragraph->Format->Style->NameLocal; 67 | # Remove trailing ^M (the paragraph marker) from Range 68 | my $Text = substr($Paragraph->Range->Text, 0, -1); 69 | 70 | if ($Style eq $Style{PlainText}) { 71 | $EmptyLine = scalar $Text =~ /^\s*$/; 72 | # Make sure plaintext starts with whitespace 73 | $Text = "\t$Text" unless $EmptyLine || $Text =~ /^\s/; 74 | print "$Text\n"; 75 | next; 76 | } 77 | 78 | # Make sure previous plaintext block has a trailing empty line 79 | print "\n" unless $EmptyLine; 80 | $EmptyLine = 1; 81 | 82 | if (defined $ListItem && !$ListStyle{$Style}) { 83 | print "=back\n\n"; 84 | undef $ListItem; 85 | } 86 | 87 | if ($Style eq $Style{Heading1}) { 88 | print "=head1 $Text\n\n"; 89 | } 90 | elsif ($Style eq $Style{Heading2}) { 91 | print "=head2 $Text\n\n"; 92 | } 93 | elsif ($ListStyle{$Style} && $Style ne $Style{ListContinue}) { 94 | unless (defined $ListItem) { 95 | print "=over 4\n\n"; 96 | $ListItem = 0; 97 | } 98 | 99 | my $Bullet = ''; 100 | $Bullet = '* ' if $Style eq $Style{ListBullet}; 101 | $Bullet = sprintf "%d. ", ++$ListItem if $Style eq $Style{ListNumber}; 102 | print "=item $Bullet$Text\n\n"; 103 | } 104 | else { 105 | printf "%s\n\n", wrap('', '', $Text); 106 | } 107 | } 108 | 109 | $Doc->{Saved} = 1; 110 | $Doc->Close; 111 | -------------------------------------------------------------------------------- /eg/word2xxx.pl: -------------------------------------------------------------------------------- 1 | # Convert MS Word files to other formats using the builtin file converters 2 | # 3 | # Ideas: 4 | # - Use PrintToFile to support PostScript etc. too 5 | # - Ask before overwriting output file 6 | # - Disable execution of AutoOpen macros: $Word->WordBasic->DisableAutoMacros? 7 | # 8 | use strict; 9 | use Win32::OLE qw(in); 10 | 11 | my $Word = Win32::OLE->new('Word.Application', 'Quit') 12 | or die "Couldn't run Word"; 13 | 14 | my $OutputFormat = shift; 15 | my ($SaveFormat,$FormatName); 16 | foreach my $Conv (in $Word->FileConverters) { 17 | next unless $Conv->{CanSave}; 18 | my $ClassName = $Conv->{ClassName}; 19 | 20 | if (@ARGV == 0) { 21 | # Print list of converter names if run without arguments 22 | printf("%4d %s %s %s\n", $Conv->{SaveFormat}, $ClassName, 23 | '.' x (26 - length($ClassName)), $Conv->{FormatName}); 24 | } 25 | elsif ($ClassName =~ /^$OutputFormat/oi) { 26 | $SaveFormat = $Conv->{SaveFormat}; 27 | $FormatName = $Conv->{FormatName}; 28 | last; 29 | } 30 | } 31 | 32 | exit unless @ARGV; 33 | 34 | unless (defined $SaveFormat) { 35 | print "No fileconverter for \"$OutputFormat\" found!\n"; 36 | print "Run word2xxx without arguments to get a list of converter names.\n"; 37 | exit; 38 | } 39 | 40 | shift; 41 | my ($InFile, $OutFile) = @ARGV; 42 | $InFile = Win32::GetCwd() . "/$InFile" if $InFile !~ /^(\w:)?[\/\\]/; 43 | $OutFile = Win32::GetCwd() . "/$OutFile" if $OutFile !~ /^(\w:)?[\/\\]/; 44 | 45 | unless (-f $InFile) { 46 | print "Inputfile $InFile does not exist!\n"; 47 | exit; 48 | } 49 | 50 | printf("Convert 'Word' format to '%s' format:\nInput: %s\nOutput: %s\n", 51 | $FormatName, $InFile, $OutFile); 52 | 53 | my $Doc = $Word->Documents->Open($InFile); 54 | $Doc->SaveAs({FileName => $OutFile, FileFormat => $SaveFormat}); 55 | $Doc->Close; 56 | -------------------------------------------------------------------------------- /hints/cygwin.pl: -------------------------------------------------------------------------------- 1 | $self->{CC} = 'g++'; 2 | $self->{LD} = 'g++'; 3 | $self->{LIBS} = ['-L/lib/w32api -lnetapi32 -lwininet -lversion -lmpr -lodbc32 -lodbccp32 -lwinmm -lole32 -loleaut32 -luuid -lcomctl32 -lgdi32 -lcomdlg32 -lntdll']; 4 | $self->{LDDLFLAGS} .= "-shared $Config{ccflags}"; 5 | -------------------------------------------------------------------------------- /lib/OLE.pm: -------------------------------------------------------------------------------- 1 | # Compatibility layer for applications using the old toplevel OLE.pm. 2 | # New code should use Win32::OLE 3 | 4 | # This file is based on ../lib/OLE.pm from ActiveState build 315. 5 | 6 | # Compatibility notes: 7 | # - "GetObject" -> "GetActiveObject" 8 | # - "keys %$collection" -> "Win32::OLE::Enum->All($collection)" 9 | # or "in $Collection" 10 | # - "unnamed" default method retries 11 | 12 | ######################################################################## 13 | # package Win32; 14 | ######################################################################## 15 | 16 | *Win32::OLELastError = sub { return OLE->LastError() }; 17 | 18 | 19 | ######################################################################## 20 | package OLE::Variant; 21 | ######################################################################## 22 | 23 | use Win32::OLE qw(CP_ACP); 24 | use Win32::OLE::Variant; 25 | 26 | use strict; 27 | use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $_NewEnum $_Unique); 28 | @ISA = qw(Win32::OLE::Variant); 29 | 30 | $Warn = 0; 31 | $LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT 32 | $CP = CP_ACP; 33 | $_NewEnum = 0; 34 | $_Unique = 0; 35 | 36 | sub new { 37 | my $self = shift; 38 | my $variant = $self->SUPER::new(@_); 39 | $OLE::LastError = $Win32::OLE->LastError unless defined $variant; 40 | return $variant; 41 | } 42 | 43 | 44 | ######################################################################## 45 | package OLE::Tie; 46 | ######################################################################## 47 | use strict; 48 | use vars qw(@ISA); 49 | @ISA = qw(Win32::OLE::Tie); 50 | 51 | # !!! It is VERY important that Win32::OLE::Tie::DESTROY gets called. !!! 52 | # If you subclass DESTROY, don't forget to call $self->SUPER::DESTROY. 53 | # Otherwise the OLE interfaces will not be released until process termination! 54 | 55 | # Retry default method if property doesn't exist 56 | sub FETCH { 57 | my ($self,$key) = @_; 58 | return $self->SUPER::Fetch($key, 1); 59 | } 60 | 61 | sub STORE { 62 | my ($self,$key,$value) = @_; 63 | $self->SUPER::Store($key, $value, 1); 64 | } 65 | 66 | # Enumerate collection members, not object properties 67 | *FIRSTKEY = *Win32::OLE::Tie::FIRSTENUM; 68 | *NEXTKEY = *Win32::OLE::Tie::NEXTENUM; 69 | 70 | 71 | ######################################################################## 72 | package OLE; 73 | ######################################################################## 74 | use Win32::OLE qw(CP_ACP); 75 | 76 | # Use OleInitialize() instead of CoInitializeEx: 77 | Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE); 78 | 79 | use strict; 80 | 81 | # Disable overload; unfortunately "no overload" doesn't do it :-( 82 | # Overloading is no longer enabled by default in Win32::OLE 83 | #use overload '""' => sub {overload::StrVal($_[0])}, 84 | # '0+' => sub {overload::StrVal($_[0])}; 85 | 86 | use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $Tie); 87 | @ISA = qw(Win32::OLE); 88 | 89 | $Warn = 0; 90 | $LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT 91 | $CP = CP_ACP; 92 | $Tie = 'OLE::Tie'; 93 | 94 | sub new { 95 | my $class = shift; 96 | $class = shift if $class eq 'OLE'; 97 | return OLE->SUPER::new($class); 98 | } 99 | 100 | sub copy { 101 | my $class = shift; 102 | $class = shift if $class eq 'OLE'; 103 | return OLE->SUPER::GetActiveObject($class); 104 | } 105 | 106 | sub AUTOLOAD { 107 | my $self = shift; 108 | my $retval; 109 | $AUTOLOAD =~ s/.*:://o; 110 | 111 | Carp::croak("Cannot autoload class method \"$AUTOLOAD\"") 112 | unless ref($self) && UNIVERSAL::isa($self,'OLE'); 113 | 114 | local $^H = 0; # !hack alert! 115 | unless (defined $self->Dispatch($AUTOLOAD, $retval, @_)) { 116 | # Retry default method 117 | $self->Dispatch(undef, $retval, $AUTOLOAD, @_); 118 | } 119 | return $retval; 120 | } 121 | 122 | *CreateObject = \&new; 123 | *GetObject = \© 124 | 125 | # Automation data types. 126 | 127 | sub VT_EMPTY {0;} 128 | sub VT_NULL {1;} 129 | sub VT_I2 {2;} 130 | sub VT_I4 {3;} 131 | sub VT_R4 {4;} 132 | sub VT_R8 {5;} 133 | sub VT_CY {6;} 134 | sub VT_DATE {7;} 135 | sub VT_BSTR {8;} 136 | sub VT_DISPATCH {9;} 137 | sub VT_ERROR {10;} 138 | sub VT_BOOL {11;} 139 | sub VT_VARIANT {12;} 140 | sub VT_UNKNOWN {13;} 141 | sub VT_I1 {16;} 142 | sub VT_UI1 {17;} 143 | sub VT_UI2 {18;} 144 | sub VT_UI4 {19;} 145 | sub VT_I8 {20;} 146 | sub VT_UI8 {21;} 147 | sub VT_INT {22;} 148 | sub VT_UINT {23;} 149 | sub VT_VOID {24;} 150 | sub VT_HRESULT {25;} 151 | sub VT_PTR {26;} 152 | sub VT_SAFEARRAY {27;} 153 | sub VT_CARRAY {28;} 154 | sub VT_USERDEFINED {29;} 155 | sub VT_LPSTR {30;} 156 | sub VT_LPWSTR {31;} 157 | sub VT_FILETIME {64;} 158 | sub VT_BLOB {65;} 159 | sub VT_STREAM {66;} 160 | sub VT_STORAGE {67;} 161 | sub VT_STREAMED_OBJECT {68;} 162 | sub VT_STORED_OBJECT {69;} 163 | sub VT_BLOB_OBJECT {70;} 164 | sub VT_CF {71;} 165 | sub VT_CLSID {72;} 166 | 167 | sub TKIND_ENUM {0;} 168 | sub TKIND_RECORD {1;} 169 | sub TKIND_MODULE {2;} 170 | sub TKIND_INTERFACE {3;} 171 | sub TKIND_DISPATCH {4;} 172 | sub TKIND_COCLASS {5;} 173 | sub TKIND_ALIAS {6;} 174 | sub TKIND_UNION {7;} 175 | sub TKIND_MAX {8;} 176 | 177 | 1; 178 | -------------------------------------------------------------------------------- /lib/Win32/OLE/Const.pm: -------------------------------------------------------------------------------- 1 | # The documentation is at the __END__ 2 | 3 | package Win32::OLE::Const; 4 | 5 | use strict; 6 | use Carp; 7 | use Win32::OLE; 8 | 9 | my $Typelibs; 10 | sub _Typelib { 11 | my ($clsid,$title,$version,$langid,$filename) = @_; 12 | # Filenames might have a resource index appended to it. 13 | $filename = $1 if $filename =~ /^(.*\.(?:dll|exe))(\\\d+)$/i; 14 | # Ignore if it looks like a file but doesn't exist. 15 | # We don't verify existence of monikers or filenames 16 | # without a full pathname. 17 | return if $filename =~ /^\w:\\.*\.(exe|dll)$/ && !-f $filename; 18 | push @$Typelibs, \@_; 19 | } 20 | unless (__PACKAGE__->_Typelibs("TypeLib")) { 21 | warn("Cannot access HKEY_CLASSES_ROOT\\Typelib"); 22 | } 23 | # Enumerate 32bit type libraries on Win64 24 | __PACKAGE__->_Typelibs("Wow6432Node\\TypeLib"); 25 | 26 | sub import { 27 | my ($self,$name,$major,$minor,$language,$codepage) = @_; 28 | return unless defined($name) && $name !~ /^\s*$/; 29 | $self->Load($name,$major,$minor,$language,$codepage,scalar caller); 30 | } 31 | 32 | sub EnumTypeLibs { 33 | my ($self,$callback) = @_; 34 | foreach (@$Typelibs) { &$callback(@$_) } 35 | return; 36 | } 37 | 38 | sub Load { 39 | my ($self,$name,$major,$minor,$language,$codepage,$caller) = @_; 40 | 41 | if (UNIVERSAL::isa($name,'Win32::OLE')) { 42 | my $typelib = $name->GetTypeInfo->GetContainingTypeLib; 43 | return _Constants($typelib, undef); 44 | } 45 | 46 | undef $minor unless defined $major; 47 | my $typelib = $self->LoadRegTypeLib($name,$major,$minor, 48 | $language,$codepage); 49 | return _Constants($typelib, $caller); 50 | } 51 | 52 | sub LoadRegTypeLib { 53 | my ($self,$name,$major,$minor,$language,$codepage) = @_; 54 | undef $minor unless defined $major; 55 | 56 | unless (defined($name) && $name !~ /^\s*$/) { 57 | carp "Win32::OLE::Const->Load: No or invalid type library name"; 58 | return; 59 | } 60 | 61 | my @found; 62 | foreach my $Typelib (@$Typelibs) { 63 | my ($clsid,$title,$version,$langid,$filename) = @$Typelib; 64 | next unless $title =~ /^$name/; 65 | next unless $version =~ /^([0-9a-fA-F]+)\.([0-9a-fA-F]+)$/; 66 | my ($maj,$min) = (hex($1), hex($2)); 67 | next if defined($major) && $maj != $major; 68 | next if defined($minor) && $min < $minor; 69 | next if defined($language) && $language != $langid; 70 | push @found, [$clsid,$maj,$min,$langid,$filename]; 71 | } 72 | 73 | unless (@found) { 74 | carp "No type library matching \"$name\" found"; 75 | return; 76 | } 77 | 78 | @found = sort { 79 | # Prefer greater version number 80 | my $res = $b->[1] <=> $a->[1]; 81 | $res = $b->[2] <=> $a->[2] if $res == 0; 82 | # Prefer default language for equal version numbers 83 | $res = -1 if $res == 0 && $a->[3] == 0; 84 | $res = 1 if $res == 0 && $b->[3] == 0; 85 | $res; 86 | } @found; 87 | 88 | #printf "Loading %s\n", join(' ', @{$found[0]}); 89 | return _LoadRegTypeLib(@{$found[0]},$codepage); 90 | } 91 | 92 | 1; 93 | 94 | __END__ 95 | 96 | =head1 NAME 97 | 98 | Win32::OLE::Const - Extract constant definitions from TypeLib 99 | 100 | =head1 SYNOPSIS 101 | 102 | use Win32::OLE::Const 'Microsoft Excel'; 103 | printf "xlMarkerStyleDot = %d\n", xlMarkerStyleDot; 104 | 105 | my $wd = Win32::OLE::Const->Load("Microsoft Word 8\\.0 Object Library"); 106 | foreach my $key (keys %$wd) { 107 | printf "$key = %s\n", $wd->{$key}; 108 | } 109 | 110 | =head1 DESCRIPTION 111 | 112 | This modules makes all constants from a registered OLE type library 113 | available to the Perl program. The constant definitions can be 114 | imported as functions, providing compile time name checking. 115 | Alternatively the constants can be returned in a hash reference 116 | which avoids defining lots of functions of unknown names. 117 | 118 | =head2 Functions/Methods 119 | 120 | =over 4 121 | 122 | =item use Win32::OLE::Const 123 | 124 | The C statement can be used to directly import the constant names 125 | and values into the users namespace. 126 | 127 | use Win32::OLE::Const (TYPELIB,MAJOR,MINOR,LANGUAGE); 128 | 129 | The TYPELIB argument specifies a regular expression for searching 130 | through the registry for the type library. Note that this argument is 131 | implicitly prefixed with C<^> to speed up matches in the most common 132 | cases. Use a typelib name like ".*Excel" to match anywhere within the 133 | description. TYPELIB is the only required argument. 134 | 135 | The MAJOR and MINOR arguments specify the requested version of 136 | the type specification. If the MAJOR argument is used then only 137 | typelibs with exactly this major version number will be matched. The 138 | MINOR argument however specifies the minimum acceptable minor version. 139 | MINOR is ignored if MAJOR is undefined. 140 | 141 | If the LANGUAGE argument is used then only typelibs with exactly this 142 | language id will be matched. 143 | 144 | The module will select the typelib with the highest version number 145 | satisfying the request. If no language id is specified then a the default 146 | language (0) will be preferred over the others. 147 | 148 | Note that only constants with valid Perl variable names will be exported, 149 | i.e. names matching this regexp: C. 150 | 151 | =item Win32::OLE::Const->Load 152 | 153 | The Win32::OLE::Const->Load method returns a reference to a hash of 154 | constant definitions. 155 | 156 | my $const = Win32::OLE::Const->Load(TYPELIB,MAJOR,MINOR,LANGUAGE); 157 | 158 | The parameters are the same as for the C case. 159 | 160 | This method is generally preferable when the typelib uses a non-english 161 | language and the constant names contain locale specific characters not 162 | allowed in Perl variable names. 163 | 164 | Another advantage is that all available constants can now be enumerated. 165 | 166 | The load method also accepts an OLE object as a parameter. In this case 167 | the OLE object is queried about its containing type library and no registry 168 | search is done at all. Interestingly this seems to be slower. 169 | 170 | =back 171 | 172 | =head1 EXAMPLES 173 | 174 | The first example imports all Excel constants names into the main namespace 175 | and prints the value of xlMarkerStyleDot (-4118). 176 | 177 | use Win32::OLE::Const ('Microsoft Excel 8.0 Object Library'); 178 | print "xlMarkerStyleDot = %d\n", xlMarkerStyleDot; 179 | 180 | The second example returns all Word constants in a hash ref. 181 | 182 | use Win32::OLE::Const; 183 | my $wd = Win32::OLE::Const->Load("Microsoft Word 8.0 Object Library"); 184 | foreach my $key (keys %$wd) { 185 | printf "$key = %s\n", $wd->{$key}; 186 | } 187 | printf "wdGreen = %s\n", $wd->{wdGreen}; 188 | 189 | The last example uses an OLE object to specify the type library: 190 | 191 | use Win32::OLE; 192 | use Win32::OLE::Const; 193 | my $Excel = Win32::OLE->new('Excel.Application', 'Quit'); 194 | my $xl = Win32::OLE::Const->Load($Excel); 195 | 196 | 197 | =head1 AUTHORS/COPYRIGHT 198 | 199 | This module is part of the Win32::OLE distribution. 200 | 201 | =cut 202 | -------------------------------------------------------------------------------- /lib/Win32/OLE/Enum.pm: -------------------------------------------------------------------------------- 1 | # The documentation is at the __END__ 2 | 3 | package Win32::OLE::Enum; 4 | 1; 5 | 6 | # everything is pure XS in Win32::OLE::Enum 7 | # - new 8 | # - DESTROY 9 | # 10 | # - All 11 | # - Clone 12 | # - Next 13 | # - Reset 14 | # - Skip 15 | 16 | __END__ 17 | 18 | =head1 NAME 19 | 20 | Win32::OLE::Enum - OLE Automation Collection Objects 21 | 22 | =head1 SYNOPSIS 23 | 24 | my $Sheets = $Excel->Workbooks(1)->Worksheets; 25 | my $Enum = Win32::OLE::Enum->new($Sheets); 26 | my @Sheets = $Enum->All; 27 | 28 | while (defined(my $Sheet = $Enum->Next)) { ... } 29 | 30 | =head1 DESCRIPTION 31 | 32 | This module provides an interface to OLE collection objects from 33 | Perl. It defines an enumerator object closely mirroring the 34 | functionality of the IEnumVARIANT interface. 35 | 36 | Please note that the Reset() method is not available in all implementations 37 | of OLE collections (like Excel 7). In that case the Enum object is good 38 | only for a single walk through of the collection. 39 | 40 | =head2 Functions/Methods 41 | 42 | =over 8 43 | 44 | =item Win32::OLE::Enum->new($object) 45 | 46 | Creates an enumerator for $object, which must be a valid OLE collection 47 | object. Note that correctly implemented collection objects must support 48 | the C and C methods, so creating an enumerator is not always 49 | necessary. 50 | 51 | =item $Enum->All() 52 | 53 | Returns a list of all objects in the collection. You have to call 54 | $Enum->Reset() before the enumerator can be used again. The previous 55 | position in the collection is lost. 56 | 57 | This method can also be called as a class method: 58 | 59 | my @list = Win32::OLE::Enum->All($Collection); 60 | 61 | =item $Enum->Clone() 62 | 63 | Returns a clone of the enumerator maintaining the current position within 64 | the collection (if possible). Note that the C method is often not 65 | implemented. Use $Enum->Clone() in an eval block to avoid dying if you 66 | are not sure that Clone is supported. 67 | 68 | =item $Enum->Next( [$count] ) 69 | 70 | Returns the next element of the collection. In a list context the optional 71 | $count argument specifies the number of objects to be returned. In a scalar 72 | context only the last of at most $count retrieved objects is returned. The 73 | default for $count is 1. 74 | 75 | =item $Enum->Reset() 76 | 77 | Resets the enumeration sequence to the beginning. There is no guarantee that 78 | the exact same set of objects will be enumerated again (e.g. when enumerating 79 | files in a directory). The methods return value indicates the success of the 80 | operation. (Note that the Reset() method seems to be unimplemented in some 81 | applications like Excel 7. Use it in an eval block to avoid dying.) 82 | 83 | =item $Enum->Skip( [$count] ) 84 | 85 | Skip the next $count elements of the enumeration. The default for $count is 1. 86 | The functions returns TRUE if at least $count elements could be skipped. It 87 | returns FALSE if not enough elements were left. 88 | 89 | =back 90 | 91 | =head1 AUTHORS/COPYRIGHT 92 | 93 | This module is part of the Win32::OLE distribution. 94 | 95 | =cut 96 | -------------------------------------------------------------------------------- /lib/Win32/OLE/Lite.pm: -------------------------------------------------------------------------------- 1 | package Win32::OLE; 2 | 3 | sub _croak { require Carp; Carp::croak(@_) } 4 | 5 | unless (defined &Dispatch) { 6 | DynaLoader::boot_DynaLoader('DynaLoader') 7 | unless defined(&DynaLoader::dl_load_file); 8 | my $file; 9 | foreach my $dir (@INC) { 10 | my $try = "$dir/auto/Win32/OLE/OLE.dll"; 11 | last if $file = (-f $try && $try); 12 | } 13 | _croak("Can't locate loadable object for module Win32::OLE". 14 | " in \@INC (\@INC contains: @INC)") 15 | unless $file; # wording similar to error from 'require' 16 | 17 | my $libref = DynaLoader::dl_load_file($file, 0) or 18 | _croak("Can't load '$file' for module Win32::OLE: ". 19 | DynaLoader::dl_error()."\n"); 20 | 21 | my $boot_symbol_ref = DynaLoader::dl_find_symbol($libref, "boot_Win32__OLE") 22 | or _croak("Can't find 'boot_Win32__OLE' symbol in $file\n"); 23 | 24 | my $xs = DynaLoader::dl_install_xsub("Win32::OLE::bootstrap", 25 | $boot_symbol_ref, $file); 26 | &$xs('Win32::OLE'); 27 | } 28 | 29 | if (defined &DB::sub && !defined $_Unique) { 30 | warn "Win32::OLE operating in debugging mode: _Unique => 1\n"; 31 | $_Unique = 1; 32 | } 33 | 34 | $Warn = 1; 35 | 36 | sub CP_ACP {0;} # ANSI codepage 37 | sub CP_OEMCP {1;} # OEM codepage 38 | sub CP_MACCP {2;} 39 | sub CP_UTF7 {65000;} 40 | sub CP_UTF8 {65001;} 41 | 42 | sub DISPATCH_METHOD {1;} 43 | sub DISPATCH_PROPERTYGET {2;} 44 | sub DISPATCH_PROPERTYPUT {4;} 45 | sub DISPATCH_PROPERTYPUTREF {8;} 46 | 47 | sub COINIT_MULTITHREADED {0;} # Default 48 | sub COINIT_APARTMENTTHREADED {2;} # Use single threaded apartment model 49 | 50 | # Bogus COINIT_* values to indicate special cases: 51 | sub COINIT_OLEINITIALIZE {-1;} # Use OleInitialize instead of CoInitializeEx 52 | sub COINIT_NO_INITIALIZE {-2;} # We are already initialized, just believe me 53 | 54 | sub HRESULT { 55 | my $hr = shift; 56 | $hr -= 2**32 if $hr & 0x80000000; 57 | return $hr; 58 | } 59 | 60 | # CreateObject is defined here only because it is documented in the 61 | # "Learning Perl on Win32 Systems" Gecko book. Please use Win32::OLE->new(). 62 | sub CreateObject { 63 | if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) { 64 | $AUTOLOAD = ref($_[0]) . '::CreateObject'; 65 | goto &AUTOLOAD; 66 | } 67 | 68 | # Hack to allow C<$obj = CreateObject Win32::OLE 'My.App';>. Although this 69 | # is contrary to the Gecko, we just make it work since it doesn't hurt. 70 | return Win32::OLE->new($_[1]) if $_[0] eq 'Win32::OLE'; 71 | 72 | # Gecko form: C<$success = Win32::OLE::CreateObject('My.App',$obj);> 73 | $_[1] = Win32::OLE->new($_[0]); 74 | return defined $_[1]; 75 | } 76 | 77 | sub LastError { 78 | unless (defined $_[0]) { 79 | # Win32::OLE::LastError() will always return $Win32::OLE::LastError 80 | return $LastError; 81 | } 82 | 83 | if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) { 84 | $AUTOLOAD = ref($_[0]) . '::LastError'; 85 | goto &AUTOLOAD; 86 | } 87 | 88 | #no strict 'refs'; 89 | my $LastError = "$_[0]::LastError"; 90 | $$LastError = $_[1] if defined $_[1]; 91 | return $$LastError; 92 | } 93 | 94 | my $Options = "^(?:CP|LCID|Warn|Variant|_NewEnum|_Unique)\$"; 95 | 96 | sub Option { 97 | if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) { 98 | $AUTOLOAD = ref($_[0]) . '::Option'; 99 | goto &AUTOLOAD; 100 | } 101 | 102 | my $class = shift; 103 | 104 | if (@_ == 1) { 105 | my $option = shift; 106 | return ${"${class}::$option"} if $option =~ /$Options/o; 107 | _croak("Invalid $class option: $option"); 108 | } 109 | 110 | while (@_) { 111 | my ($option,$value) = splice @_, 0, 2; 112 | _croak("Invalid $class option: $option") if $option !~ /$Options/o; 113 | ${"${class}::$option"} = $value; 114 | $class->_Unique() if $option eq "_Unique"; 115 | } 116 | } 117 | 118 | sub Invoke { 119 | my ($self,$method,@args) = @_; 120 | $self->Dispatch($method, my $retval, @args); 121 | return $retval; 122 | } 123 | 124 | sub LetProperty { 125 | my ($self,$method,@args) = @_; 126 | $self->Dispatch([DISPATCH_PROPERTYPUT, $method], my $retval, @args); 127 | return $retval; 128 | } 129 | 130 | sub SetProperty { 131 | my ($self,$method,@args) = @_; 132 | my $wFlags = DISPATCH_PROPERTYPUT; 133 | if (@args) { 134 | # If the value is an object then it will be set by reference! 135 | my $value = $args[-1]; 136 | if (UNIVERSAL::isa($value, 'Win32::OLE')) { 137 | $wFlags = DISPATCH_PROPERTYPUTREF; 138 | } 139 | elsif (UNIVERSAL::isa($value,'Win32::OLE::Variant')) { 140 | my $type = $value->Type & ~0xfff; # VT_TYPEMASK 141 | # VT_DISPATCH and VT_UNKNOWN represent COM objects 142 | $wFlags = DISPATCH_PROPERTYPUTREF if $type == 9 || $type == 13; 143 | } 144 | } 145 | $self->Dispatch([$wFlags, $method], my $retval, @args); 146 | return $retval; 147 | } 148 | 149 | sub AUTOLOAD { 150 | my $self = shift; 151 | my $autoload = substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1; 152 | _croak("Cannot autoload class method \"$autoload\"") 153 | unless ref($self) && UNIVERSAL::isa($self, 'Win32::OLE'); 154 | my $success = $self->Dispatch($autoload, my $retval, @_); 155 | unless (defined $success || ($^H & 0x200) != 0) { 156 | # Retry default method if C 157 | $self->Dispatch(undef, $retval, $autoload, @_); 158 | } 159 | return $retval; 160 | } 161 | 162 | sub in { 163 | my @res; 164 | while (@_) { 165 | my $this = shift; 166 | if (UNIVERSAL::isa($this, 'Win32::OLE')) { 167 | push @res, Win32::OLE::Enum->All($this); 168 | } 169 | elsif (ref($this) eq 'ARRAY') { 170 | push @res, @$this; 171 | } 172 | else { 173 | push @res, $this; 174 | } 175 | } 176 | return @res; 177 | } 178 | 179 | sub valof { 180 | my $arg = shift; 181 | if (UNIVERSAL::isa($arg, 'Win32::OLE')) { 182 | require Win32::OLE::Variant; 183 | my ($class) = overload::StrVal($arg) =~ /^([^=]+)=/; 184 | #no strict 'refs'; 185 | local $Win32::OLE::CP = ${"${class}::CP"}; 186 | local $Win32::OLE::LCID = ${"${class}::LCID"}; 187 | #use strict 'refs'; 188 | # VT_EMPTY variant for return code 189 | my $variant = Win32::OLE::Variant->new; 190 | $arg->Dispatch(undef, $variant); 191 | return $variant->Value; 192 | } 193 | $arg = $arg->Value if UNIVERSAL::can($arg, 'Value'); 194 | return $arg; 195 | } 196 | 197 | sub with { 198 | my $object = shift; 199 | while (@_) { 200 | my $property = shift; 201 | $object->{$property} = shift; 202 | } 203 | } 204 | 205 | ######################################################################## 206 | 207 | package Win32::OLE::Tie; 208 | 209 | # Only retry default method under C 210 | sub FETCH { 211 | my ($self,$key) = @_; 212 | if ($key eq "_NewEnum") { 213 | (my $class = ref $self) =~ s/::Tie$//; 214 | return [Win32::OLE::Enum->All($self)] if ${"${class}::_NewEnum"}; 215 | } 216 | $self->Fetch($key, !$Win32::OLE::Strict); 217 | } 218 | 219 | sub STORE { 220 | my ($self,$key,$value) = @_; 221 | $self->Store($key, $value, !$Win32::OLE::Strict); 222 | } 223 | 224 | 1; 225 | -------------------------------------------------------------------------------- /lib/Win32/OLE/NEWS.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =head1 NAME 4 | 5 | Win32::OLE::NEWS - What's new in Win32::OLE 6 | 7 | This file contains a history of user visible changes to the 8 | Win32::OLE::* modules. Only new features and major bug fixes that 9 | might affect backwards compatibility are included. 10 | 11 | =head1 Version 0.18 12 | 13 | =head2 VT_CY and VT_DECIMAL return values handled differently 14 | 15 | The new C option enables values of VT_CY or VT_DECIMAL type 16 | to be returned as Win32::OLE::Variant objects instead of being 17 | converted into strings and numbers respectively. This is similar to 18 | the change in Win32::OLE version 0.12 to VT_DATE and VT_ERROR values. 19 | The Win32::OLE::Variant module must be included to make sure that 20 | VT_CY and VT_DECIMAL values behave as before in numeric or string 21 | contexts. 22 | 23 | Because the new behavior is potentially incompatible, it must be 24 | explicitly enabled: 25 | 26 | Win32::OLE->Option(Variant => 1); 27 | 28 | 29 | =head1 Version 0.17 30 | 31 | =head2 New nullstring() function in Win32::OLE::Variant 32 | 33 | The nullstring() function returns a VT_BSTR variant containing a NULL 34 | string pointer. Note that this is not the same as a VT_BSTR variant 35 | containing the empty string "". 36 | 37 | The nullstring() return value is equivalent to the Visual Basic 38 | C constant. 39 | 40 | 41 | =head1 Version 0.16 42 | 43 | =head2 Improved Unicode support 44 | 45 | Passing Unicode strings to methods and properties as well as returning 46 | Unicode strings back to Perl works now with both Perl 5.6 and 5.8. 47 | Note that the Unicode support in 5.8 is much more complete than in 5.6 48 | or 5.6.1. 49 | 50 | C objects can now be passed to methods or assigned to 51 | properties. 52 | 53 | You must enable Unicode support by switching Win32::OLE to the UTF8 54 | codepage: 55 | 56 | Win32::OLE->Option(CP => Win32::OLE::CP_UTF8()); 57 | 58 | 59 | =head1 Version 0.13 60 | 61 | =head2 New nothing() function in Win32::OLE::Variant 62 | 63 | The nothing() function returns an empty VT_DISPATCH variant. It can be 64 | used to clear an object reference stored in a property 65 | 66 | use Win32::OLE::Variant qw(:DEFAULT nothing); 67 | # ... 68 | $object->{Property} = nothing; 69 | 70 | This has the same effect as the Visual Basic statement 71 | 72 | Set object.Property = Nothing 73 | 74 | =head2 New _NewEnum and _Unique options 75 | 76 | There are two new options available for the Win32::OLE->Option class 77 | method: C<_NewEnum> provides the elements of a collection object 78 | directly as the value of a C<_NewEnum> property. The C<_Unique> 79 | option guarantees that Win32::OLE will not create multiple proxy 80 | objects for the same underlying COM/OLE object. 81 | 82 | Both options are only really useful to tree traversal programs or 83 | during debugging. 84 | 85 | 86 | =head1 Version 0.12 87 | 88 | =head2 Additional error handling functionality 89 | 90 | The Warn option can now be set to a CODE reference too. For example, 91 | 92 | Win32::OLE->Option(Warn => 3); 93 | 94 | could now be written as 95 | 96 | Win32::OLE->Option(Warn => \&Carp::croak); 97 | 98 | This can even be used to emulate the VisualBasic C construct: 100 | 101 | Win32::OLE->Option(Warn => sub {goto CheckError}); 102 | # ... your normal OLE code here ... 103 | 104 | CheckError: 105 | # ... your error handling code here ... 106 | 107 | =head2 Builtin event loop 108 | 109 | Processing OLE events required a polling loop before, e.g. 110 | 111 | my $Quit; 112 | #... 113 | until ($Quit) { 114 | Win32::OLE->SpinMessageLoop; 115 | Win32::Sleep(100); 116 | } 117 | package BrowserEvents; 118 | sub OnQuit { $Quit = 1 } 119 | 120 | This is inefficient and a bit odd. This version of Win32::OLE now 121 | supports a standard messageloop: 122 | 123 | Win32::OLE->MessageLoop(); 124 | 125 | package BrowserEvents; 126 | sub OnQuit { Win32::OLE->QuitMessageLoop } 127 | 128 | =head2 Free unused OLE libraries 129 | 130 | Previous versions of Win32::OLE would call the CoFreeUnusedLibraries() 131 | API whenever an OLE object was destroyed. This made sure that OLE 132 | libraries would be unloaded as soon as they were no longer needed. 133 | Unfortunately, objects implemented in Visual Basic tend to crash 134 | during this call, as they pretend to be ready for unloading, when in 135 | fact, they aren't. 136 | 137 | The unloading of object libraries is really only important for long 138 | running processes that might instantiate a huge number of B 139 | objects over time. Therefore this API is no longer called 140 | automatically. The functionality is now available explicitly to those 141 | who want or need it by calling a Win32::OLE class method: 142 | 143 | Win32::OLE->FreeUnusedLibraries(); 144 | 145 | =head2 The "Win32::OLE" article from "The Perl Journal #10" 146 | 147 | The article is Copyright 1998 by I. http://www.tpj.com 149 | 150 | It originally appeared in I # 10 and appears here 151 | courtesy of Jon Orwant and I. The sample code from 152 | the article is in the F file. 153 | 154 | =head2 VARIANT->Put() bug fixes 155 | 156 | The Put() method didn't work correctly for arrays of type VT_BSTR, 157 | VT_DISPATH or VT_UNKNOWN. This has been fixed. 158 | 159 | =head2 Error message fixes 160 | 161 | Previous versions of Win32::OLE gave a wrong argument index for some 162 | OLE error messages (the number was too large by 1). This should be 163 | fixed now. 164 | 165 | =head2 VT_DATE and VT_ERROR return values handled differently 166 | 167 | Method calls and property accesses returning a VT_DATE or VT_ERROR 168 | value would previously translate the value to string or integer 169 | format. This has been changed to return a Win32::OLE::Variant object. 170 | The return values will behave as before if the Win32::OLE::Variant 171 | module is being used. This module overloads the conversion of 172 | the objects to strings and numbers. 173 | 174 | 175 | =head1 Version 0.11 (changes since 0.1008) 176 | 177 | =head2 new DHTML typelib browser 178 | 179 | The Win32::OLE distribution now contains a type library browser. It 180 | is written in PerlScript, generating dynamic HTML. It requires 181 | Internet Explorer 4.0 or later. You'll find it in 182 | F. It should be available in the ActivePerl 183 | HTML help under Win32::OLE::Browser. 184 | 185 | After selecting a library, type or member you can press F1 to call up 186 | the corresponding help file at the appropriate location. 187 | 188 | =head2 VT_DECIMAL support 189 | 190 | The Win32::OLE::Variant module now supports VT_DECIMAL variants too. 191 | They are not "officially" allowed in OLE Automation calls, but even 192 | Microsoft's "ActiveX Data Objects" sometimes returns VT_DECIMAL 193 | values. 194 | 195 | VT_DECIMAL variables are stored as 96-bit integers scaled by a 196 | variable power of 10. The power of 10 scaling factor specifies the 197 | number of digits to the right of the decimal point, and ranges from 0 198 | to 28. With a scale of 0 (no decimal places), the largest possible 199 | value is +/-79,228,162,514,264,337,593,543,950,335. With a 28 decimal 200 | places, the largest value is +/-7.9228162514264337593543950335 and the 201 | smallest, non-zero value is +/-0.0000000000000000000000000001. 202 | 203 | =head1 Version 0.1008 204 | 205 | =head2 new LetProperty() object method 206 | 207 | In Win32::OLE property assignment using the hash syntax is equivalent 208 | to the Visual Basic C syntax (I assignment): 209 | 210 | $Object->{Property} = $OtherObject; 211 | 212 | corresponds to this Visual Basic statement: 213 | 214 | Set Object.Property = OtherObject 215 | 216 | To get the I treatment of the Visual Basic C statement 217 | 218 | Object.Property = OtherObject 219 | 220 | you have to use the LetProperty() object method in Perl: 221 | 222 | $Object->LetProperty($Property, $OtherObject); 223 | 224 | =head2 new HRESULT() function 225 | 226 | The HRESULT() function converts an unsigned number into a signed HRESULT 227 | error value as used by OLE internally. This is necessary because Perl 228 | treats all hexadecimal constants as unsigned. To check if the last OLE 229 | function returned "Member not found" (0x80020003) you can write: 230 | 231 | if (Win32::OLE->LastError == HRESULT(0x80020003)) { 232 | # your error recovery here 233 | } 234 | 235 | =head1 Version 0.1007 (changes since 0.1005) 236 | 237 | =head2 OLE Event support 238 | 239 | This version of Win32::OLE contains B level support for OLE events. The 240 | user interface is still subject to change. There are ActiveX objects / controls 241 | that don't fire events under the current implementation. 242 | 243 | Events are enabled for a specific object with the Win32::OLE->WithEvents() 244 | class method: 245 | 246 | Win32::OLE->WithEvents(OBJECT, HANDLER, INTERFACE) 247 | 248 | Please read further documentation in Win32::OLE. 249 | 250 | =head2 GetObject() and GetActiveObject() now support optional DESTRUCTOR argument 251 | 252 | It is now possible to specify a DESTRUCTOR argument to the GetObject() and 253 | GetActiveObject() class methods. They work identical to the new() DESTRUCTOR 254 | argument. 255 | 256 | =head2 Remote object instantiation via DCOM 257 | 258 | This has actually been in Win32::OLE since 0.0608, but somehow never got 259 | documented. You can provide an array reference in place of the usual PROGID 260 | parameter to Win32::OLE->new(): 261 | 262 | OBJ = Win32::OLE->new([MACHINE, PRODID]); 263 | 264 | The array must contain two elements: the name of the MACHINE and the PROGID. 265 | This will try to create the object on the remote MACHINE. 266 | 267 | =head2 Enumerate all Win32::OLE objects 268 | 269 | This class method returns the number Win32::OLE objects currently in 270 | existence. It will call the optional CALLBACK function for each of 271 | these objects: 272 | 273 | $Count = Win32::OLE->EnumAllObjects(sub { 274 | my $Object = shift; 275 | my $Class = Win32::OLE->QueryObjectType($Object); 276 | printf "# Object=%s Class=%s\n", $Object, $Class; 277 | }); 278 | 279 | The EnumAllObjects() method is primarily a debugging tool. It can be 280 | used e.g. in an END block to check if all external connections have 281 | been properly destroyed. 282 | 283 | =head2 The VARIANT->Put() method now returns the VARIANT object itself 284 | 285 | This allows chaining of Put() method calls to set multiple values in an 286 | array variant: 287 | 288 | $Array->Put(0,0,$First_value)->Put(0,1,$Another_value); 289 | 290 | =head2 The VARIANT->Put(ARRAYREF) form allows assignment to a complete SAFEARRAY 291 | 292 | This allows automatic conversion from a list of lists to a SAFEARRAY. 293 | You can now write: 294 | 295 | my $Array = Variant(VT_ARRAY|VT_R8, [1,2], 2); 296 | $Array->Put([[1,2], [3,4]]); 297 | 298 | instead of the tedious: 299 | 300 | $Array->Put(1,0,1); 301 | $Array->Put(1,1,2); 302 | $Array->Put(2,0,3); 303 | $Array->Put(2,1,4); 304 | 305 | =head2 New Variant formatting methods 306 | 307 | There are four new methods for formatting variant values: Currency(), Date(), 308 | Number() and Time(). For example: 309 | 310 | my $v = Variant(VT_DATE, "April 1 99"); 311 | print $v->Date(DATE_LONGDATE), "\n"; 312 | print $v->Date("ddd',' MMM dd yy"), "\n"; 313 | 314 | will print: 315 | 316 | Thursday, April 01, 1999 317 | Thu, Apr 01 99 318 | 319 | =head2 new Win32::OLE::NLS methods: SendSettingChange() and SetLocaleInfo() 320 | 321 | SendSettingChange() sends a WM_SETTINGCHANGE message to all top level windows. 322 | 323 | SetLocaleInfo() allows changing elements in the user override section of the 324 | locale database. Unfortunately these changes are not automatically available 325 | to further Variant formatting; you have to call SendSettingChange() first. 326 | 327 | =head2 Win32::OLE::Const now correctly treats version numbers as hex 328 | 329 | The minor and major version numbers of type libraries have been treated as 330 | decimal. This was wrong. They are now correctly decoded as hex. 331 | 332 | =head2 more robust global destruction of Win32::OLE objects 333 | 334 | The final destruction of Win32::OLE objects has always been somewhat fragile. 335 | The reason for this is that Perl doesn't honour reference counts during global 336 | destruction but destroys objects in seemingly random order. This can lead 337 | to leaked database connections or unterminated external objects. The only 338 | solution was to make all objects lexical and hope that no object would be 339 | trapped in a closure. Alternatively all objects could be explicitly set to 340 | C, which doesn't work very well with exception handling. 341 | 342 | With version 0.1007 of Win32::OLE this problem should be gone: The module 343 | keeps a list of active Win32::OLE objects. It uses an END block to destroy 344 | all objects at program termination I the Perl's global destruction 345 | starts. Objects still existing at program termination are now destroyed in 346 | reverse order of creation. The effect is similar to explicitly calling 347 | Win32::OLE->Uninitialize() just prior to termination. 348 | 349 | =head1 Version 0.1005 (changes since 0.1003) 350 | 351 | Win32::OLE 0.1005 has been release with ActivePerl build 509. It is also 352 | included in the I Update. 353 | 354 | =head2 optional DESTRUCTOR for GetActiveObject() GetObject() class methods 355 | 356 | The GetActiveObject() and GetObject() class method now also support an 357 | optional DESTRUCTOR parameter just like Win32::OLE->new(). The DESTRUCTOR 358 | is executed when the last reference to this object goes away. It is 359 | generally considered C to stop applications that you did not 360 | start yourself. 361 | 362 | =head2 new Variant object method: $object->Copy() 363 | 364 | See L. 365 | 366 | =head2 new Win32::OLE->Option() class method 367 | 368 | The Option() class method can be used to inspect and modify 369 | L. The single argument form retrieves 370 | the value of an option: 371 | 372 | my $CP = Win32::OLE->Option('CP'); 373 | 374 | A single call can be used to set multiple options simultaneously: 375 | 376 | Win32::OLE->Option(CP => CP_ACP, Warn => 3); 377 | 378 | Currently the following options exist: CP, LCID and C. 379 | 380 | =cut 381 | -------------------------------------------------------------------------------- /lib/Win32/OLE/NLS.pm: -------------------------------------------------------------------------------- 1 | # The documentation is at the __END__ 2 | 3 | package Win32::OLE::NLS; 4 | require Win32::OLE; # Make sure the XS bootstrap has been called 5 | 6 | use strict; 7 | use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA); 8 | 9 | use Exporter; 10 | @ISA = qw(Exporter); 11 | 12 | @EXPORT = qw( 13 | CompareString 14 | LCMapString 15 | GetLocaleInfo 16 | GetStringType 17 | GetSystemDefaultLangID 18 | GetSystemDefaultLCID 19 | GetUserDefaultLangID 20 | GetUserDefaultLCID 21 | 22 | MAKELANGID 23 | PRIMARYLANGID 24 | SUBLANGID 25 | LANG_SYSTEM_DEFAULT 26 | LANG_USER_DEFAULT 27 | MAKELCID 28 | LANGIDFROMLCID 29 | LOCALE_SYSTEM_DEFAULT 30 | LOCALE_USER_DEFAULT 31 | ); 32 | 33 | @EXPORT_OK = qw(SetLocaleInfo SendSettingChange); 34 | 35 | %EXPORT_TAGS = 36 | ( 37 | CT => [qw(CT_CTYPE1 CT_CTYPE2 CT_CTYPE3)], 38 | C1 => [qw(C1_UPPER C1_LOWER C1_DIGIT C1_SPACE C1_PUNCT 39 | C1_CNTRL C1_BLANK C1_XDIGIT C1_ALPHA)], 40 | C2 => [qw(C2_LEFTTORIGHT C2_RIGHTTOLEFT C2_EUROPENUMBER 41 | C2_EUROPESEPARATOR C2_EUROPETERMINATOR C2_ARABICNUMBER 42 | C2_COMMONSEPARATOR C2_BLOCKSEPARATOR C2_SEGMENTSEPARATOR 43 | C2_WHITESPACE C2_OTHERNEUTRAL C2_NOTAPPLICABLE)], 44 | C3 => [qw(C3_NONSPACING C3_DIACRITIC C3_VOWELMARK C3_SYMBOL C3_KATAKANA 45 | C3_HIRAGANA C3_HALFWIDTH C3_FULLWIDTH C3_IDEOGRAPH C3_KASHIDA 46 | C3_ALPHA C3_NOTAPPLICABLE)], 47 | NORM => [qw(NORM_IGNORECASE NORM_IGNORENONSPACE NORM_IGNORESYMBOLS 48 | NORM_IGNOREWIDTH NORM_IGNOREKANATYPE NORM_IGNOREKASHIDA)], 49 | LCMAP => [qw(LCMAP_LOWERCASE LCMAP_UPPERCASE LCMAP_SORTKEY LCMAP_HALFWIDTH 50 | LCMAP_FULLWIDTH LCMAP_HIRAGANA LCMAP_KATAKANA)], 51 | LANG => [qw(LANG_NEUTRAL LANG_ALBANIAN LANG_ARABIC LANG_BAHASA 52 | LANG_BULGARIAN LANG_CATALAN LANG_CHINESE LANG_CZECH LANG_DANISH 53 | LANG_DUTCH LANG_ENGLISH LANG_FINNISH LANG_FRENCH LANG_GERMAN 54 | LANG_GREEK LANG_HEBREW LANG_HUNGARIAN LANG_ICELANDIC 55 | LANG_ITALIAN LANG_JAPANESE LANG_KOREAN LANG_NORWEGIAN 56 | LANG_POLISH LANG_PORTUGUESE LANG_RHAETO_ROMAN LANG_ROMANIAN 57 | LANG_RUSSIAN LANG_SERBO_CROATIAN LANG_SLOVAK LANG_SPANISH 58 | LANG_SWEDISH LANG_THAI LANG_TURKISH LANG_URDU)], 59 | SUBLANG => [qw(SUBLANG_NEUTRAL SUBLANG_DEFAULT SUBLANG_SYS_DEFAULT 60 | SUBLANG_CHINESE_SIMPLIFIED SUBLANG_CHINESE_TRADITIONAL 61 | SUBLANG_DUTCH SUBLANG_DUTCH_BELGIAN SUBLANG_ENGLISH_US 62 | SUBLANG_ENGLISH_UK SUBLANG_ENGLISH_AUS SUBLANG_ENGLISH_CAN 63 | SUBLANG_ENGLISH_NZ SUBLANG_ENGLISH_EIRE SUBLANG_FRENCH 64 | SUBLANG_FRENCH_BELGIAN SUBLANG_FRENCH_CANADIAN 65 | SUBLANG_FRENCH_SWISS SUBLANG_GERMAN SUBLANG_GERMAN_SWISS 66 | SUBLANG_GERMAN_AUSTRIAN SUBLANG_ITALIAN SUBLANG_ITALIAN_SWISS 67 | SUBLANG_NORWEGIAN_BOKMAL SUBLANG_NORWEGIAN_NYNORSK 68 | SUBLANG_PORTUGUESE SUBLANG_PORTUGUESE_BRAZILIAN 69 | SUBLANG_SERBO_CROATIAN_CYRILLIC SUBLANG_SERBO_CROATIAN_LATIN 70 | SUBLANG_SPANISH SUBLANG_SPANISH_MEXICAN 71 | SUBLANG_SPANISH_MODERN)], 72 | CTRY => [qw(CTRY_DEFAULT CTRY_AUSTRALIA CTRY_AUSTRIA CTRY_BELGIUM 73 | CTRY_BRAZIL CTRY_CANADA CTRY_DENMARK CTRY_FINLAND CTRY_FRANCE 74 | CTRY_GERMANY CTRY_ICELAND CTRY_IRELAND CTRY_ITALY CTRY_JAPAN 75 | CTRY_MEXICO CTRY_NETHERLANDS CTRY_NEW_ZEALAND CTRY_NORWAY 76 | CTRY_PORTUGAL CTRY_PRCHINA CTRY_SOUTH_KOREA CTRY_SPAIN 77 | CTRY_SWEDEN CTRY_SWITZERLAND CTRY_TAIWAN CTRY_UNITED_KINGDOM 78 | CTRY_UNITED_STATES)], 79 | LOCALE => [qw(LOCALE_NOUSEROVERRIDE LOCALE_ILANGUAGE LOCALE_SLANGUAGE 80 | LOCALE_SENGLANGUAGE LOCALE_SABBREVLANGNAME 81 | LOCALE_SNATIVELANGNAME LOCALE_ICOUNTRY LOCALE_SCOUNTRY 82 | LOCALE_SENGCOUNTRY LOCALE_SABBREVCTRYNAME LOCALE_SNATIVECTRYNAME 83 | LOCALE_IDEFAULTLANGUAGE LOCALE_IDEFAULTCOUNTRY 84 | LOCALE_IDEFAULTCODEPAGE LOCALE_IDEFAULTANSICODEPAGE LOCALE_SLIST 85 | LOCALE_IMEASURE LOCALE_SDECIMAL LOCALE_STHOUSAND 86 | LOCALE_SGROUPING LOCALE_IDIGITS LOCALE_ILZERO LOCALE_INEGNUMBER 87 | LOCALE_SNATIVEDIGITS LOCALE_SCURRENCY LOCALE_SINTLSYMBOL 88 | LOCALE_SMONDECIMALSEP LOCALE_SMONTHOUSANDSEP LOCALE_SMONGROUPING 89 | LOCALE_ICURRDIGITS LOCALE_IINTLCURRDIGITS LOCALE_ICURRENCY 90 | LOCALE_INEGCURR LOCALE_SDATE LOCALE_STIME LOCALE_SSHORTDATE 91 | LOCALE_SLONGDATE LOCALE_STIMEFORMAT LOCALE_IDATE LOCALE_ILDATE 92 | LOCALE_ITIME LOCALE_ITIMEMARKPOSN LOCALE_ICENTURY LOCALE_ITLZERO 93 | LOCALE_IDAYLZERO LOCALE_IMONLZERO LOCALE_S1159 LOCALE_S2359 94 | LOCALE_ICALENDARTYPE LOCALE_IOPTIONALCALENDAR 95 | LOCALE_IFIRSTDAYOFWEEK LOCALE_IFIRSTWEEKOFYEAR LOCALE_SDAYNAME1 96 | LOCALE_SDAYNAME2 LOCALE_SDAYNAME3 LOCALE_SDAYNAME4 97 | LOCALE_SDAYNAME5 LOCALE_SDAYNAME6 LOCALE_SDAYNAME7 98 | LOCALE_SABBREVDAYNAME1 LOCALE_SABBREVDAYNAME2 99 | LOCALE_SABBREVDAYNAME3 LOCALE_SABBREVDAYNAME4 100 | LOCALE_SABBREVDAYNAME5 LOCALE_SABBREVDAYNAME6 101 | LOCALE_SABBREVDAYNAME7 LOCALE_SMONTHNAME1 LOCALE_SMONTHNAME2 102 | LOCALE_SMONTHNAME3 LOCALE_SMONTHNAME4 LOCALE_SMONTHNAME5 103 | LOCALE_SMONTHNAME6 LOCALE_SMONTHNAME7 LOCALE_SMONTHNAME8 104 | LOCALE_SMONTHNAME9 LOCALE_SMONTHNAME10 LOCALE_SMONTHNAME11 105 | LOCALE_SMONTHNAME12 LOCALE_SMONTHNAME13 LOCALE_SABBREVMONTHNAME1 106 | LOCALE_SABBREVMONTHNAME2 LOCALE_SABBREVMONTHNAME3 107 | LOCALE_SABBREVMONTHNAME4 LOCALE_SABBREVMONTHNAME5 108 | LOCALE_SABBREVMONTHNAME6 LOCALE_SABBREVMONTHNAME7 109 | LOCALE_SABBREVMONTHNAME8 LOCALE_SABBREVMONTHNAME9 110 | LOCALE_SABBREVMONTHNAME10 LOCALE_SABBREVMONTHNAME11 111 | LOCALE_SABBREVMONTHNAME12 LOCALE_SABBREVMONTHNAME13 112 | LOCALE_SPOSITIVESIGN LOCALE_SNEGATIVESIGN LOCALE_IPOSSIGNPOSN 113 | LOCALE_INEGSIGNPOSN LOCALE_IPOSSYMPRECEDES LOCALE_IPOSSEPBYSPACE 114 | LOCALE_INEGSYMPRECEDES LOCALE_INEGSEPBYSPACE)], 115 | TIME => [qw(TIME_NOMINUTESORSECONDS TIME_NOSECONDS TIME_NOTIMEMARKER 116 | TIME_FORCE24HOURFORMAT)], 117 | DATE => [qw(DATE_SHORTDATE DATE_LONGDATE DATE_USE_ALT_CALENDAR 118 | DATE_YEARMONTH DATE_LTRREADING DATE_RTLREADING)], 119 | ); 120 | 121 | foreach my $tag (keys %EXPORT_TAGS) { 122 | push @EXPORT_OK, @{$EXPORT_TAGS{$tag}}; 123 | } 124 | 125 | # Character Type Flags 126 | sub CT_CTYPE1 { 0x0001 } 127 | sub CT_CTYPE2 { 0x0002 } 128 | sub CT_CTYPE3 { 0x0004 } 129 | 130 | # Character Type 1 Bits 131 | sub C1_UPPER { 0x0001 } 132 | sub C1_LOWER { 0x0002 } 133 | sub C1_DIGIT { 0x0004 } 134 | sub C1_SPACE { 0x0008 } 135 | sub C1_PUNCT { 0x0010 } 136 | sub C1_CNTRL { 0x0020 } 137 | sub C1_BLANK { 0x0040 } 138 | sub C1_XDIGIT { 0x0080 } 139 | sub C1_ALPHA { 0x0100 } 140 | 141 | # Character Type 2 Bits 142 | sub C2_LEFTTORIGHT { 0x1 } 143 | sub C2_RIGHTTOLEFT { 0x2 } 144 | sub C2_EUROPENUMBER { 0x3 } 145 | sub C2_EUROPESEPARATOR { 0x4 } 146 | sub C2_EUROPETERMINATOR { 0x5 } 147 | sub C2_ARABICNUMBER { 0x6 } 148 | sub C2_COMMONSEPARATOR { 0x7 } 149 | sub C2_BLOCKSEPARATOR { 0x8 } 150 | sub C2_SEGMENTSEPARATOR { 0x9 } 151 | sub C2_WHITESPACE { 0xA } 152 | sub C2_OTHERNEUTRAL { 0xB } 153 | sub C2_NOTAPPLICABLE { 0x0 } 154 | 155 | # Character Type 3 Bits 156 | sub C3_NONSPACING { 0x0001 } 157 | sub C3_DIACRITIC { 0x0002 } 158 | sub C3_VOWELMARK { 0x0004 } 159 | sub C3_SYMBOL { 0x0008 } 160 | sub C3_KATAKANA { 0x0010 } 161 | sub C3_HIRAGANA { 0x0020 } 162 | sub C3_HALFWIDTH { 0x0040 } 163 | sub C3_FULLWIDTH { 0x0080 } 164 | sub C3_IDEOGRAPH { 0x0100 } 165 | sub C3_KASHIDA { 0x0200 } 166 | sub C3_ALPHA { 0x8000 } 167 | sub C3_NOTAPPLICABLE { 0x0 } 168 | 169 | # String Flags 170 | sub NORM_IGNORECASE { 0x0001 } 171 | sub NORM_IGNORENONSPACE { 0x0002 } 172 | sub NORM_IGNORESYMBOLS { 0x0004 } 173 | sub NORM_IGNOREWIDTH { 0x0008 } 174 | sub NORM_IGNOREKANATYPE { 0x0040 } 175 | sub NORM_IGNOREKASHIDA { 0x40000} 176 | 177 | # Locale Dependent Mapping Flags 178 | sub LCMAP_LOWERCASE { 0x0100 } 179 | sub LCMAP_UPPERCASE { 0x0200 } 180 | sub LCMAP_SORTKEY { 0x0400 } 181 | sub LCMAP_HALFWIDTH { 0x0800 } 182 | sub LCMAP_FULLWIDTH { 0x1000 } 183 | sub LCMAP_HIRAGANA { 0x2000 } 184 | sub LCMAP_KATAKANA { 0x4000 } 185 | 186 | # Primary Language Identifier 187 | sub LANG_NEUTRAL { 0x00 } 188 | sub LANG_ALBANIAN { 0x1c } 189 | sub LANG_ARABIC { 0x01 } 190 | sub LANG_BAHASA { 0x21 } 191 | sub LANG_BULGARIAN { 0x02 } 192 | sub LANG_CATALAN { 0x03 } 193 | sub LANG_CHINESE { 0x04 } 194 | sub LANG_CZECH { 0x05 } 195 | sub LANG_DANISH { 0x06 } 196 | sub LANG_DUTCH { 0x13 } 197 | sub LANG_ENGLISH { 0x09 } 198 | sub LANG_FINNISH { 0x0b } 199 | sub LANG_FRENCH { 0x0c } 200 | sub LANG_GERMAN { 0x07 } 201 | sub LANG_GREEK { 0x08 } 202 | sub LANG_HEBREW { 0x0d } 203 | sub LANG_HUNGARIAN { 0x0e } 204 | sub LANG_ICELANDIC { 0x0f } 205 | sub LANG_ITALIAN { 0x10 } 206 | sub LANG_JAPANESE { 0x11 } 207 | sub LANG_KOREAN { 0x12 } 208 | sub LANG_NORWEGIAN { 0x14 } 209 | sub LANG_POLISH { 0x15 } 210 | sub LANG_PORTUGUESE { 0x16 } 211 | sub LANG_RHAETO_ROMAN { 0x17 } 212 | sub LANG_ROMANIAN { 0x18 } 213 | sub LANG_RUSSIAN { 0x19 } 214 | sub LANG_SERBO_CROATIAN { 0x1a } 215 | sub LANG_SLOVAK { 0x1b } 216 | sub LANG_SPANISH { 0x0a } 217 | sub LANG_SWEDISH { 0x1d } 218 | sub LANG_THAI { 0x1e } 219 | sub LANG_TURKISH { 0x1f } 220 | sub LANG_URDU { 0x20 } 221 | 222 | # Sublanguage Identifier 223 | sub SUBLANG_NEUTRAL { 0x00 } 224 | sub SUBLANG_DEFAULT { 0x01 } 225 | sub SUBLANG_SYS_DEFAULT { 0x02 } 226 | sub SUBLANG_CHINESE_SIMPLIFIED { 0x02 } 227 | sub SUBLANG_CHINESE_TRADITIONAL { 0x01 } 228 | sub SUBLANG_DUTCH { 0x01 } 229 | sub SUBLANG_DUTCH_BELGIAN { 0x02 } 230 | sub SUBLANG_ENGLISH_US { 0x01 } 231 | sub SUBLANG_ENGLISH_UK { 0x02 } 232 | sub SUBLANG_ENGLISH_AUS { 0x03 } 233 | sub SUBLANG_ENGLISH_CAN { 0x04 } 234 | sub SUBLANG_ENGLISH_NZ { 0x05 } 235 | sub SUBLANG_ENGLISH_EIRE { 0x06 } 236 | sub SUBLANG_FRENCH { 0x01 } 237 | sub SUBLANG_FRENCH_BELGIAN { 0x02 } 238 | sub SUBLANG_FRENCH_CANADIAN { 0x03 } 239 | sub SUBLANG_FRENCH_SWISS { 0x04 } 240 | sub SUBLANG_GERMAN { 0x01 } 241 | sub SUBLANG_GERMAN_SWISS { 0x02 } 242 | sub SUBLANG_GERMAN_AUSTRIAN { 0x03 } 243 | sub SUBLANG_ITALIAN { 0x01 } 244 | sub SUBLANG_ITALIAN_SWISS { 0x02 } 245 | sub SUBLANG_NORWEGIAN_BOKMAL { 0x01 } 246 | sub SUBLANG_NORWEGIAN_NYNORSK { 0x02 } 247 | sub SUBLANG_PORTUGUESE { 0x02 } 248 | sub SUBLANG_PORTUGUESE_BRAZILIAN { 0x01 } 249 | sub SUBLANG_SERBO_CROATIAN_CYRILLIC { 0x02 } 250 | sub SUBLANG_SERBO_CROATIAN_LATIN { 0x01 } 251 | sub SUBLANG_SPANISH { 0x01 } 252 | sub SUBLANG_SPANISH_MEXICAN { 0x02 } 253 | sub SUBLANG_SPANISH_MODERN { 0x03 } 254 | 255 | # Country codes 256 | sub CTRY_DEFAULT { 0 } 257 | sub CTRY_AUSTRALIA { 61 } 258 | sub CTRY_AUSTRIA { 43 } 259 | sub CTRY_BELGIUM { 32 } 260 | sub CTRY_BRAZIL { 55 } 261 | sub CTRY_CANADA { 2 } 262 | sub CTRY_DENMARK { 45 } 263 | sub CTRY_FINLAND { 358 } 264 | sub CTRY_FRANCE { 33 } 265 | sub CTRY_GERMANY { 49 } 266 | sub CTRY_ICELAND { 354 } 267 | sub CTRY_IRELAND { 353 } 268 | sub CTRY_ITALY { 39 } 269 | sub CTRY_JAPAN { 81 } 270 | sub CTRY_MEXICO { 52 } 271 | sub CTRY_NETHERLANDS { 31 } 272 | sub CTRY_NEW_ZEALAND { 64 } 273 | sub CTRY_NORWAY { 47 } 274 | sub CTRY_PORTUGAL { 351 } 275 | sub CTRY_PRCHINA { 86 } 276 | sub CTRY_SOUTH_KOREA { 82 } 277 | sub CTRY_SPAIN { 34 } 278 | sub CTRY_SWEDEN { 46 } 279 | sub CTRY_SWITZERLAND { 41 } 280 | sub CTRY_TAIWAN { 886 } 281 | sub CTRY_UNITED_KINGDOM { 44 } 282 | sub CTRY_UNITED_STATES { 1 } 283 | 284 | # Locale Types 285 | sub LOCALE_NOUSEROVERRIDE { 0x80000000 } 286 | sub LOCALE_ILANGUAGE { 0x0001 } 287 | sub LOCALE_SLANGUAGE { 0x0002 } 288 | sub LOCALE_SENGLANGUAGE { 0x1001 } 289 | sub LOCALE_SABBREVLANGNAME { 0x0003 } 290 | sub LOCALE_SNATIVELANGNAME { 0x0004 } 291 | sub LOCALE_ICOUNTRY { 0x0005 } 292 | sub LOCALE_SCOUNTRY { 0x0006 } 293 | sub LOCALE_SENGCOUNTRY { 0x1002 } 294 | sub LOCALE_SABBREVCTRYNAME { 0x0007 } 295 | sub LOCALE_SNATIVECTRYNAME { 0x0008 } 296 | sub LOCALE_IDEFAULTLANGUAGE { 0x0009 } 297 | sub LOCALE_IDEFAULTCOUNTRY { 0x000A } 298 | sub LOCALE_IDEFAULTCODEPAGE { 0x000B } 299 | sub LOCALE_IDEFAULTANSICODEPAGE { 0x1004 } 300 | sub LOCALE_SLIST { 0x000C } 301 | sub LOCALE_IMEASURE { 0x000D } 302 | sub LOCALE_SDECIMAL { 0x000E } 303 | sub LOCALE_STHOUSAND { 0x000F } 304 | sub LOCALE_SGROUPING { 0x0010 } 305 | sub LOCALE_IDIGITS { 0x0011 } 306 | sub LOCALE_ILZERO { 0x0012 } 307 | sub LOCALE_INEGNUMBER { 0x1010 } 308 | sub LOCALE_SNATIVEDIGITS { 0x0013 } 309 | sub LOCALE_SCURRENCY { 0x0014 } 310 | sub LOCALE_SINTLSYMBOL { 0x0015 } 311 | sub LOCALE_SMONDECIMALSEP { 0x0016 } 312 | sub LOCALE_SMONTHOUSANDSEP { 0x0017 } 313 | sub LOCALE_SMONGROUPING { 0x0018 } 314 | sub LOCALE_ICURRDIGITS { 0x0019 } 315 | sub LOCALE_IINTLCURRDIGITS { 0x001A } 316 | sub LOCALE_ICURRENCY { 0x001B } 317 | sub LOCALE_INEGCURR { 0x001C } 318 | sub LOCALE_SDATE { 0x001D } 319 | sub LOCALE_STIME { 0x001E } 320 | sub LOCALE_SSHORTDATE { 0x001F } 321 | sub LOCALE_SLONGDATE { 0x0020 } 322 | sub LOCALE_STIMEFORMAT { 0x1003 } 323 | sub LOCALE_IDATE { 0x0021 } 324 | sub LOCALE_ILDATE { 0x0022 } 325 | sub LOCALE_ITIME { 0x0023 } 326 | sub LOCALE_ITIMEMARKPOSN { 0x1005 } 327 | sub LOCALE_ICENTURY { 0x0024 } 328 | sub LOCALE_ITLZERO { 0x0025 } 329 | sub LOCALE_IDAYLZERO { 0x0026 } 330 | sub LOCALE_IMONLZERO { 0x0027 } 331 | sub LOCALE_S1159 { 0x0028 } 332 | sub LOCALE_S2359 { 0x0029 } 333 | sub LOCALE_ICALENDARTYPE { 0x1009 } 334 | sub LOCALE_IOPTIONALCALENDAR { 0x100B } 335 | sub LOCALE_IFIRSTDAYOFWEEK { 0x100C } 336 | sub LOCALE_IFIRSTWEEKOFYEAR { 0x100D } 337 | sub LOCALE_SDAYNAME1 { 0x002A } 338 | sub LOCALE_SDAYNAME2 { 0x002B } 339 | sub LOCALE_SDAYNAME3 { 0x002C } 340 | sub LOCALE_SDAYNAME4 { 0x002D } 341 | sub LOCALE_SDAYNAME5 { 0x002E } 342 | sub LOCALE_SDAYNAME6 { 0x002F } 343 | sub LOCALE_SDAYNAME7 { 0x0030 } 344 | sub LOCALE_SABBREVDAYNAME1 { 0x0031 } 345 | sub LOCALE_SABBREVDAYNAME2 { 0x0032 } 346 | sub LOCALE_SABBREVDAYNAME3 { 0x0033 } 347 | sub LOCALE_SABBREVDAYNAME4 { 0x0034 } 348 | sub LOCALE_SABBREVDAYNAME5 { 0x0035 } 349 | sub LOCALE_SABBREVDAYNAME6 { 0x0036 } 350 | sub LOCALE_SABBREVDAYNAME7 { 0x0037 } 351 | sub LOCALE_SMONTHNAME1 { 0x0038 } 352 | sub LOCALE_SMONTHNAME2 { 0x0039 } 353 | sub LOCALE_SMONTHNAME3 { 0x003A } 354 | sub LOCALE_SMONTHNAME4 { 0x003B } 355 | sub LOCALE_SMONTHNAME5 { 0x003C } 356 | sub LOCALE_SMONTHNAME6 { 0x003D } 357 | sub LOCALE_SMONTHNAME7 { 0x003E } 358 | sub LOCALE_SMONTHNAME8 { 0x003F } 359 | sub LOCALE_SMONTHNAME9 { 0x0040 } 360 | sub LOCALE_SMONTHNAME10 { 0x0041 } 361 | sub LOCALE_SMONTHNAME11 { 0x0042 } 362 | sub LOCALE_SMONTHNAME12 { 0x0043 } 363 | sub LOCALE_SMONTHNAME13 { 0x100E } 364 | sub LOCALE_SABBREVMONTHNAME1 { 0x0044 } 365 | sub LOCALE_SABBREVMONTHNAME2 { 0x0045 } 366 | sub LOCALE_SABBREVMONTHNAME3 { 0x0046 } 367 | sub LOCALE_SABBREVMONTHNAME4 { 0x0047 } 368 | sub LOCALE_SABBREVMONTHNAME5 { 0x0048 } 369 | sub LOCALE_SABBREVMONTHNAME6 { 0x0049 } 370 | sub LOCALE_SABBREVMONTHNAME7 { 0x004A } 371 | sub LOCALE_SABBREVMONTHNAME8 { 0x004B } 372 | sub LOCALE_SABBREVMONTHNAME9 { 0x004C } 373 | sub LOCALE_SABBREVMONTHNAME10 { 0x004D } 374 | sub LOCALE_SABBREVMONTHNAME11 { 0x004E } 375 | sub LOCALE_SABBREVMONTHNAME12 { 0x004F } 376 | sub LOCALE_SABBREVMONTHNAME13 { 0x100F } 377 | sub LOCALE_SPOSITIVESIGN { 0x0050 } 378 | sub LOCALE_SNEGATIVESIGN { 0x0051 } 379 | sub LOCALE_IPOSSIGNPOSN { 0x0052 } 380 | sub LOCALE_INEGSIGNPOSN { 0x0053 } 381 | sub LOCALE_IPOSSYMPRECEDES { 0x0054 } 382 | sub LOCALE_IPOSSEPBYSPACE { 0x0055 } 383 | sub LOCALE_INEGSYMPRECEDES { 0x0056 } 384 | sub LOCALE_INEGSEPBYSPACE { 0x0057 } 385 | 386 | # GetTimeFormat Flags 387 | sub TIME_NOMINUTESORSECONDS { 0x0001 } 388 | sub TIME_NOSECONDS { 0x0002 } 389 | sub TIME_NOTIMEMARKER { 0x0004 } 390 | sub TIME_FORCE24HOURFORMAT { 0x0008 } 391 | 392 | # GetDateFormat Flags 393 | sub DATE_SHORTDATE { 0x0001 } 394 | sub DATE_LONGDATE { 0x0002 } 395 | sub DATE_USE_ALT_CALENDAR { 0x0004 } 396 | sub DATE_YEARMONTH { 0x0008 } 397 | sub DATE_LTRREADING { 0x0010 } 398 | sub DATE_RTLREADING { 0x0020 } 399 | 400 | # Language Identifier Functions 401 | sub MAKELANGID { my ($p,$s) = @_; (($s & 0xffff) << 10) | ($p & 0xffff); } 402 | sub PRIMARYLANGID { my $lgid = shift; $lgid & 0x3ff; } 403 | sub SUBLANGID { my $lgid = shift; ($lgid >> 10) & 0x3f; } 404 | 405 | sub LANG_SYSTEM_DEFAULT { MAKELANGID(LANG_NEUTRAL, SUBLANG_SYS_DEFAULT); } 406 | sub LANG_USER_DEFAULT { MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT); } 407 | 408 | # Locale Identifier Functions 409 | sub MAKELCID { my $lgid = shift; $lgid & 0xffff; } 410 | sub LANGIDFROMLCID { my $lcid = shift; $lcid & 0xffff; } 411 | 412 | sub LOCALE_SYSTEM_DEFAULT { MAKELCID(LANG_SYSTEM_DEFAULT); } 413 | sub LOCALE_USER_DEFAULT { MAKELCID(LANG_USER_DEFAULT); } 414 | 415 | 1; 416 | 417 | __END__ 418 | 419 | =head1 NAME 420 | 421 | Win32::OLE::NLS - OLE National Language Support 422 | 423 | =head1 SYNOPSIS 424 | 425 | missing 426 | 427 | =head1 DESCRIPTION 428 | 429 | This module provides access to the national language support features 430 | in the F. 431 | 432 | =head2 Functions 433 | 434 | =over 8 435 | 436 | =item CompareString(LCID,FLAGS,STR1,STR2) 437 | 438 | Compare STR1 and STR2 in the LCID locale. FLAGS indicate the character 439 | traits to be used or ignored when comparing the two strings. 440 | 441 | NORM_IGNORECASE Ignore case 442 | NORM_IGNOREKANATYPE Ignore hiragana/katakana character differences 443 | NORM_IGNORENONSPACE Ignore accents, diacritics, and vowel marks 444 | NORM_IGNORESYMBOLS Ignore symbols 445 | NORM_IGNOREWIDTH Ignore character width 446 | 447 | Possible return values are: 448 | 449 | 0 Function failed 450 | 1 STR1 is less than STR2 451 | 2 STR1 is equal to STR2 452 | 3 STR1 is greater than STR2 453 | 454 | Note that you can subtract 2 from the return code to get values 455 | comparable to the C operator. 456 | 457 | =item LCMapString(LCID,FLAGS,STR) 458 | 459 | LCMapString translates STR using LCID dependent translation. 460 | Flags contains a combination of the following options: 461 | 462 | LCMAP_LOWERCASE Lowercase 463 | LCMAP_UPPERCASE Uppercase 464 | LCMAP_HALFWIDTH Narrow characters 465 | LCMAP_FULLWIDTH Wide characters 466 | LCMAP_HIRAGANA Hiragana 467 | LCMAP_KATAKANA Katakana 468 | LCMAP_SORTKEY Character sort key 469 | 470 | The following normalization options can be combined with C: 471 | 472 | NORM_IGNORECASE Ignore case 473 | NORM_IGNOREKANATYPE Ignore hiragana/katakana character differences 474 | NORM_IGNORENONSPACE Ignore accents, diacritics, and vowel marks 475 | NORM_IGNORESYMBOLS Ignore symbols 476 | NORM_IGNOREWIDTH Ignore character width 477 | 478 | The return value is the translated string. 479 | 480 | =item GetLocaleInfo(LCID,LCTYPE) 481 | 482 | Retrieve locale setting LCTYPE from the locale specified by LCID. Use 483 | LOCALE_NOUSEROVERRIDE | LCTYPE to always query the locale database. 484 | Otherwise user changes to C through the windows control panel 485 | take precedence when retrieving values for the system default locale. 486 | See the documentation below for a list of valid LCTYPE values. 487 | 488 | The return value is the contents of the requested locale setting. 489 | 490 | =item GetStringType(LCID,TYPE,STR) 491 | 492 | Retrieve type information from locale LCID about each character in STR. 493 | The requested TYPE can be one of the following 3 levels: 494 | 495 | CT_CTYPE1 ANSI C and POSIX type information 496 | CT_CTYPE2 Text layout type information 497 | CT_CTYPE3 Text processing type information 498 | 499 | The return value is a list of values, each of wich is a bitwise OR of 500 | the applicable type bits from the corresponding table below: 501 | 502 | @ct = GetStringType(LOCALE_SYSTEM_DEFAULT, CT_CTYPE1, "String"); 503 | 504 | ANSI C and POSIX character type information: 505 | 506 | C1_UPPER Uppercase 507 | C1_LOWER Lowercase 508 | C1_DIGIT Decimal digits 509 | C1_SPACE Space characters 510 | C1_PUNCT Punctuation 511 | C1_CNTRL Control characters 512 | C1_BLANK Blank characters 513 | C1_XDIGIT Hexadecimal digits 514 | C1_ALPHA Any letter 515 | 516 | Text layout type information: 517 | 518 | C2_LEFTTORIGHT Left to right 519 | C2_RIGHTTOLEFT Right to left 520 | C2_EUROPENUMBER European number, European digit 521 | C2_EUROPESEPARATOR European numeric separator 522 | C2_EUROPETERMINATOR European numeric terminator 523 | C2_ARABICNUMBER Arabic number 524 | C2_COMMONSEPARATOR Common numeric separator 525 | C2_BLOCKSEPARATOR Block separator 526 | C2_SEGMENTSEPARATOR Segment separator 527 | C2_WHITESPACE White space 528 | C2_OTHERNEUTRAL Other neutrals 529 | C2_NOTAPPLICABLE No implicit direction (e.g. ctrl codes) 530 | 531 | Text precessing type information: 532 | 533 | C3_NONSPACING Nonspacing mark 534 | C3_DIACRITIC Diacritic nonspacing mark 535 | C3_VOWELMARK Vowel nonspacing mark 536 | C3_SYMBOL Symbol 537 | C3_KATAKANA Katakana character 538 | C3_HIRAGANA Hiragana character 539 | C3_HALFWIDTH Narrow character 540 | C3_FULLWIDTH Wide character 541 | C3_IDEOGRAPH Ideograph 542 | C3_ALPHA Any letter 543 | C3_NOTAPPLICABLE Not applicable 544 | 545 | 546 | =item GetSystemDefaultLangID() 547 | 548 | Returns the system default language identifier. 549 | 550 | =item GetSystemDefaultLCID() 551 | 552 | Returns the system default locale identifier. 553 | 554 | =item GetUserDefaultLangID() 555 | 556 | Returns the user default language identifier. 557 | 558 | =item GetUserDefaultLCID() 559 | 560 | Returns the user default locale identifier. 561 | 562 | =item SendSettingChange() 563 | 564 | Sends a WM_SETTINGCHANGE message to all top level windows. 565 | 566 | =item SetLocaleInfo(LCID, LCTYPE, LCDATA) 567 | 568 | Changes an item in the user override part of the locale setting LCID. 569 | It doesn't change the system default database. The following LCTYPEs are 570 | changeable: 571 | 572 | LOCALE_ICALENDARTYPE LOCALE_SDATE 573 | LOCALE_ICURRDIGITS LOCALE_SDECIMAL 574 | LOCALE_ICURRENCY LOCALE_SGROUPING 575 | LOCALE_IDIGITS LOCALE_SLIST 576 | LOCALE_IFIRSTDAYOFWEEK LOCALE_SLONGDATE 577 | LOCALE_IFIRSTWEEKOFYEAR LOCALE_SMONDECIMALSEP 578 | LOCALE_ILZERO LOCALE_SMONGROUPING 579 | LOCALE_IMEASURE LOCALE_SMONTHOUSANDSEP 580 | LOCALE_INEGCURR LOCALE_SNEGATIVESIGN 581 | LOCALE_INEGNUMBER LOCALE_SPOSITIVESIGN 582 | LOCALE_IPAPERSIZE LOCALE_SSHORTDATE 583 | LOCALE_ITIME LOCALE_STHOUSAND 584 | LOCALE_S1159 LOCALE_STIME 585 | LOCALE_S2359 LOCALE_STIMEFORMAT 586 | LOCALE_SCURRENCY LOCALE_SYEARMONTH 587 | 588 | You have to call SendSettingChange() to activate these changes for 589 | subsequent Win32::OLE::Variant object formatting because the OLE 590 | subsystem seems to cache locale information. 591 | 592 | =item MAKELANGID(LANG,SUBLANG) 593 | 594 | Creates a language identifier from a primary language and a sublanguage. 595 | 596 | =item PRIMARYLANGID(LANGID) 597 | 598 | Retrieves the primary language from a language identifier. 599 | 600 | =item SUBLANGID(LANGID) 601 | 602 | Retrieves the sublanguage from a language identifier. 603 | 604 | =item MAKELCID(LANGID) 605 | 606 | Creates a locale identifies from a language identifier. 607 | 608 | =item LANGIDFROMLCID(LCID) 609 | 610 | Retrieves a language identifier from a locale identifier. 611 | 612 | =back 613 | 614 | =head2 Locale Types 615 | 616 | =over 8 617 | 618 | =item LOCALE_ILANGUAGE 619 | 620 | The language identifier (in hex). 621 | 622 | =item LOCALE_SLANGUAGE 623 | 624 | The localized name of the language. 625 | 626 | =item LOCALE_SENGLANGUAGE 627 | 628 | The ISO Standard 639 English name of the language. 629 | 630 | =item LOCALE_SABBREVLANGNAME 631 | 632 | The three-letter abbreviated name of the language. The first two 633 | letters are from the ISO Standard 639 language name abbreviation. The 634 | third letter indicates the sublanguage type. 635 | 636 | =item LOCALE_SNATIVELANGNAME 637 | 638 | The native name of the language. 639 | 640 | =item LOCALE_ICOUNTRY 641 | 642 | The country code, which is based on international phone codes. 643 | 644 | =item LOCALE_SCOUNTRY 645 | 646 | The localized name of the country. 647 | 648 | =item LOCALE_SENGCOUNTRY 649 | 650 | The English name of the country. 651 | 652 | =item LOCALE_SABBREVCTRYNAME 653 | 654 | The ISO Standard 3166 abbreviated name of the country. 655 | 656 | =item LOCALE_SNATIVECTRYNAME 657 | 658 | The native name of the country. 659 | 660 | =item LOCALE_IDEFAULTLANGUAGE 661 | 662 | Language identifier for the principal language spoken in this 663 | locale. 664 | 665 | =item LOCALE_IDEFAULTCOUNTRY 666 | 667 | Country code for the principal country in this locale. 668 | 669 | =item LOCALE_IDEFAULTANSICODEPAGE 670 | 671 | The ANSI code page associated with this locale. Format: 4 Unicode 672 | decimal digits plus a Unicode null terminator. 673 | 674 | XXX This should be translated by GetLocaleInfo. XXX 675 | 676 | =item LOCALE_IDEFAULTCODEPAGE 677 | 678 | The OEM code page associated with the country. 679 | 680 | =item LOCALE_SLIST 681 | 682 | Characters used to separate list items (often a comma). 683 | 684 | =item LOCALE_IMEASURE 685 | 686 | Default measurement system: 687 | 688 | 0 metric system (S.I.) 689 | 1 U.S. system 690 | 691 | =item LOCALE_SDECIMAL 692 | 693 | Characters used for the decimal separator (often a dot). 694 | 695 | =item LOCALE_STHOUSAND 696 | 697 | Characters used as the separator between groups of digits left of the decimal. 698 | 699 | =item LOCALE_SGROUPING 700 | 701 | Sizes for each group of digits to the left of the decimal. An explicit 702 | size is required for each group. Sizes are separated by semicolons. If 703 | the last value is 0, the preceding value is repeated. To group 704 | thousands, specify 3;0. 705 | 706 | =item LOCALE_IDIGITS 707 | 708 | The number of fractional digits. 709 | 710 | =item LOCALE_ILZERO 711 | 712 | Whether to use leading zeros in decimal fields. A setting of 0 713 | means use no leading zeros; 1 means use leading zeros. 714 | 715 | =item LOCALE_SNATIVEDIGITS 716 | 717 | The ten characters that are the native equivalent of the ASCII 0-9. 718 | 719 | =item LOCALE_INEGNUMBER 720 | 721 | Negative number mode. 722 | 723 | 0 (1.1) 724 | 1 -1.1 725 | 2 -1.1 726 | 3 1.1 727 | 4 1.1 728 | 729 | =item LOCALE_SCURRENCY 730 | 731 | The string used as the local monetary symbol. 732 | 733 | =item LOCALE_SINTLSYMBOL 734 | 735 | Three characters of the International monetary symbol specified in ISO 736 | 4217, Codes for the Representation of Currencies and Funds, followed 737 | by the character separating this string from the amount. 738 | 739 | =item LOCALE_SMONDECIMALSEP 740 | 741 | Characters used for the monetary decimal separators. 742 | 743 | =item LOCALE_SMONTHOUSANDSEP 744 | 745 | Characters used as monetary separator between groups of digits left of 746 | the decimal. 747 | 748 | =item LOCALE_SMONGROUPING 749 | 750 | Sizes for each group of monetary digits to the left of the decimal. An 751 | explicit size is needed for each group. Sizes are separated by 752 | semicolons. If the last value is 0, the preceding value is 753 | repeated. To group thousands, specify 3;0. 754 | 755 | =item LOCALE_ICURRDIGITS 756 | 757 | Number of fractional digits for the local monetary format. 758 | 759 | =item LOCALE_IINTLCURRDIGITS 760 | 761 | Number of fractional digits for the international monetary format. 762 | 763 | =item LOCALE_ICURRENCY 764 | 765 | Positive currency mode. 766 | 767 | 0 Prefix, no separation. 768 | 1 Suffix, no separation. 769 | 2 Prefix, 1-character separation. 770 | 3 Suffix, 1-character separation. 771 | 772 | =item LOCALE_INEGCURR 773 | 774 | Negative currency mode. 775 | 776 | 0 ($1.1) 777 | 1 -$1.1 778 | 2 $-1.1 779 | 3 $1.1- 780 | 4 $(1.1$) 781 | 5 -1.1$ 782 | 6 1.1-$ 783 | 7 1.1$- 784 | 8 -1.1 $ (space before $) 785 | 9 -$ 1.1 (space after $) 786 | 10 1.1 $- (space before $) 787 | 788 | =item LOCALE_ICALENDARTYPE 789 | 790 | The type of calendar currently in use. 791 | 792 | 1 Gregorian (as in U.S.) 793 | 2 Gregorian (always English strings) 794 | 3 Era: Year of the Emperor (Japan) 795 | 4 Era: Year of the Republic of China 796 | 5 Tangun Era (Korea) 797 | 798 | =item LOCALE_IOPTIONALCALENDAR 799 | 800 | The additional calendar types available for this LCID. Can be a 801 | null-separated list of all valid optional calendars. Value is 802 | 0 for "None available" or any of the LOCALE_ICALENDARTYPE settings. 803 | 804 | XXX null separated list should be translated by GetLocaleInfo XXX 805 | 806 | =item LOCALE_SDATE 807 | 808 | Characters used for the date separator. 809 | 810 | =item LOCALE_STIME 811 | 812 | Characters used for the time separator. 813 | 814 | =item LOCALE_STIMEFORMAT 815 | 816 | Time-formatting string. 817 | 818 | =item LOCALE_SSHORTDATE 819 | 820 | Short Date_Time formatting strings for this locale. 821 | 822 | =item LOCALE_SLONGDATE 823 | 824 | Long Date_Time formatting strings for this locale. 825 | 826 | =item LOCALE_IDATE 827 | 828 | Short Date format-ordering specifier. 829 | 830 | 0 Month - Day - Year 831 | 1 Day - Month - Year 832 | 2 Year - Month - Day 833 | 834 | =item LOCALE_ILDATE 835 | 836 | Long Date format ordering specifier. Value can be any of the valid 837 | LOCALE_IDATE settings. 838 | 839 | =item LOCALE_ITIME 840 | 841 | Time format specifier. 842 | 843 | 0 AM/PM 12-hour format. 844 | 1 24-hour format. 845 | 846 | =item LOCALE_ITIMEMARKPOSN 847 | 848 | Whether the time marker string (AM|PM) precedes or follows the time 849 | string. 850 | 0 Suffix (9:15 AM). 851 | 1 Prefix (AM 9:15). 852 | 853 | =item LOCALE_ICENTURY 854 | 855 | Whether to use full 4-digit century. 856 | 857 | 0 Two digit. 858 | 1 Full century. 859 | 860 | =item LOCALE_ITLZERO 861 | 862 | Whether to use leading zeros in time fields. 863 | 864 | 0 No leading zeros. 865 | 1 Leading zeros for hours. 866 | 867 | =item LOCALE_IDAYLZERO 868 | 869 | Whether to use leading zeros in day fields. Values as for 870 | LOCALE_ITLZERO. 871 | 872 | =item LOCALE_IMONLZERO 873 | 874 | Whether to use leading zeros in month fields. Values as for 875 | LOCALE_ITLZERO. 876 | 877 | =item LOCALE_S1159 878 | 879 | String for the AM designator. 880 | 881 | =item LOCALE_S2359 882 | 883 | String for the PM designator. 884 | 885 | =item LOCALE_IFIRSTWEEKOFYEAR 886 | 887 | Specifies which week of the year is considered first. 888 | 889 | 0 Week containing 1/1 is the first week of the year. 890 | 1 First full week following 1/1is the first week of the year. 891 | 2 First week with at least 4 days is the first week of the year. 892 | 893 | =item LOCALE_IFIRSTDAYOFWEEK 894 | 895 | Specifies the day considered first in the week. Value "0" means 896 | SDAYNAME1 and value "6" means SDAYNAME7. 897 | 898 | =item LOCALE_SDAYNAME1 .. LOCALE_SDAYNAME7 899 | 900 | Long name for Monday .. Sunday. 901 | 902 | =item LOCALE_SABBREVDAYNAME1 .. LOCALE_SABBREVDAYNAME7 903 | 904 | Abbreviated name for Monday .. Sunday. 905 | 906 | =item LOCALE_SMONTHNAME1 .. LOCALE_SMONTHNAME12 907 | 908 | Long name for January .. December. 909 | 910 | =item LOCALE_SMONTHNAME13 911 | 912 | Native name for 13th month, if it exists. 913 | 914 | =item LOCALE_SABBREVMONTHNAME1 .. LOCALE_SABBREVMONTHNAME12 915 | 916 | Abbreviated name for January .. December. 917 | 918 | =item LOCALE_SABBREVMONTHNAME13 919 | 920 | Native abbreviated name for 13th month, if it exists. 921 | 922 | =item LOCALE_SPOSITIVESIGN 923 | 924 | String value for the positive sign. 925 | 926 | =item LOCALE_SNEGATIVESIGN 927 | 928 | String value for the negative sign. 929 | 930 | =item LOCALE_IPOSSIGNPOSN 931 | 932 | Formatting index for positive values. 933 | 934 | 0 Parentheses surround the amount and the monetary symbol. 935 | 1 The sign string precedes the amount and the monetary symbol. 936 | 2 The sign string precedes the amount and the monetary symbol. 937 | 3 The sign string precedes the amount and the monetary symbol. 938 | 4 The sign string precedes the amount and the monetary symbol. 939 | 940 | =item LOCALE_INEGSIGNPOSN 941 | 942 | Formatting index for negative values. Values as for LOCALE_IPOSSIGNPOSN. 943 | 944 | =item LOCALE_IPOSSYMPRECEDES 945 | 946 | If the monetary symbol precedes, 1. If it succeeds a positive amount, 0. 947 | 948 | =item LOCALE_IPOSSEPBYSPACE 949 | 950 | If the monetary symbol is separated by a space from a positive amount, 951 | 1. Otherwise, 0. 952 | 953 | =item LOCALE_INEGSYMPRECEDES 954 | 955 | If the monetary symbol precedes, 1. If it succeeds a negative amount, 0. 956 | 957 | =item LOCALE_INEGSEPBYSPACE 958 | 959 | If the monetary symbol is separated by a space from a negative amount, 960 | 1. Otherwise, 0. 961 | 962 | =back 963 | 964 | =head1 AUTHORS/COPYRIGHT 965 | 966 | This module is part of the Win32::OLE distribution. 967 | 968 | =cut 969 | -------------------------------------------------------------------------------- /lib/Win32/OLE/TPJ.pod: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jandubois/win32-ole/27570c90dcb3cf56ef815f668cc346dc0ac099a3/lib/Win32/OLE/TPJ.pod -------------------------------------------------------------------------------- /lib/Win32/OLE/TypeInfo.pm: -------------------------------------------------------------------------------- 1 | # This module is still experimental and intentionally undocumented. 2 | # If you don't know why it is here, then you should probably not use it. 3 | 4 | package Win32::OLE::TypeInfo; 5 | 6 | use strict; 7 | use vars qw(@ISA @EXPORT @EXPORT_OK); 8 | use vars qw(@VT %TYPEFLAGS @TYPEKIND %IMPLTYPEFLAGS %PARAMFLAGS 9 | %FUNCFLAGS @CALLCONV @FUNCKIND %INVOKEKIND %VARFLAGS 10 | %LIBFLAGS @SYSKIND); 11 | 12 | use Exporter; 13 | @ISA = qw(Exporter); 14 | 15 | @EXPORT = qw( 16 | VT_EMPTY VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE 17 | VT_BSTR VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN 18 | VT_DECIMAL VT_I1 VT_UI1 VT_UI2 VT_UI4 VT_I8 VT_UI8 VT_INT 19 | VT_UINT VT_VOID VT_HRESULT VT_PTR VT_SAFEARRAY VT_CARRAY 20 | VT_USERDEFINED VT_LPSTR VT_LPWSTR VT_FILETIME VT_BLOB 21 | VT_STREAM VT_STORAGE VT_STREAMED_OBJECT VT_STORED_OBJECT 22 | VT_BLOB_OBJECT VT_CF VT_CLSID VT_VECTOR VT_ARRAY VT_BYREF 23 | VT_RESERVED VT_ILLEGAL VT_ILLEGALMASKED VT_TYPEMASK 24 | 25 | TYPEFLAG_FAPPOBJECT TYPEFLAG_FCANCREATE TYPEFLAG_FLICENSED 26 | TYPEFLAG_FPREDECLID TYPEFLAG_FHIDDEN TYPEFLAG_FCONTROL 27 | TYPEFLAG_FDUAL TYPEFLAG_FNONEXTENSIBLE TYPEFLAG_FOLEAUTOMATION 28 | TYPEFLAG_FRESTRICTED TYPEFLAG_FAGGREGATABLE TYPEFLAG_FREPLACEABLE 29 | TYPEFLAG_FDISPATCHABLE TYPEFLAG_FREVERSEBIND 30 | 31 | TKIND_ENUM TKIND_RECORD TKIND_MODULE TKIND_INTERFACE TKIND_DISPATCH 32 | TKIND_COCLASS TKIND_ALIAS TKIND_UNION TKIND_MAX 33 | 34 | IMPLTYPEFLAG_FDEFAULT IMPLTYPEFLAG_FSOURCE IMPLTYPEFLAG_FRESTRICTED 35 | IMPLTYPEFLAG_FDEFAULTVTABLE 36 | 37 | PARAMFLAG_NONE PARAMFLAG_FIN PARAMFLAG_FOUT PARAMFLAG_FLCID 38 | PARAMFLAG_FRETVAL PARAMFLAG_FOPT PARAMFLAG_FHASDEFAULT 39 | 40 | FUNCFLAG_FRESTRICTED FUNCFLAG_FSOURCE FUNCFLAG_FBINDABLE 41 | FUNCFLAG_FREQUESTEDIT FUNCFLAG_FDISPLAYBIND FUNCFLAG_FDEFAULTBIND 42 | FUNCFLAG_FHIDDEN FUNCFLAG_FUSESGETLASTERROR FUNCFLAG_FDEFAULTCOLLELEM 43 | FUNCFLAG_FUIDEFAULT FUNCFLAG_FNONBROWSABLE FUNCFLAG_FREPLACEABLE 44 | FUNCFLAG_FIMMEDIATEBIND 45 | 46 | CC_FASTCALL CC_CDECL CC_MSCPASCAL CC_PASCAL CC_MACPASCAL CC_STDCALL 47 | CC_FPFASTCALL CC_SYSCALL CC_MPWCDECL CC_MPWPASCAL CC_MAX 48 | 49 | INVOKE_FUNC INVOKE_PROPERTYGET INVOKE_PROPERTYPUT INVOKE_PROPERTYPUTREF 50 | 51 | VARFLAG_FREADONLY VARFLAG_FSOURCE VARFLAG_FBINDABLE VARFLAG_FREQUESTEDIT 52 | VARFLAG_FDISPLAYBIND VARFLAG_FDEFAULTBIND VARFLAG_FHIDDEN VARFLAG_FRESTRICTED 53 | VARFLAG_FDEFAULTCOLLELEM VARFLAG_FUIDEFAULT VARFLAG_FNONBROWSABLE 54 | VARFLAG_FREPLACEABLE VARFLAG_FIMMEDIATEBIND 55 | 56 | LIBFLAG_FRESTRICTED LIBFLAG_FCONTROL LIBFLAG_FHIDDEN 57 | SYS_WIN16 SYS_WIN32 SYS_MAC 58 | 59 | FUNC_VIRTUAL FUNC_PUREVIRTUAL FUNC_NONVIRTUAL FUNC_STATIC FUNC_DISPATCH 60 | 61 | @VT %TYPEFLAGS @TYPEKIND %IMPLTYPEFLAGS %PARAMFLAGS 62 | %FUNCFLAGS @CALLCONV @FUNCKIND %INVOKEKIND %VARFLAGS %LIBFLAGS @SYSKIND 63 | ); 64 | 65 | # Lib Flags 66 | # --------- 67 | 68 | sub LIBFLAG_FRESTRICTED () { 0x01; } 69 | sub LIBFLAG_FCONTROL () { 0x02; } 70 | sub LIBFLAG_FHIDDEN () { 0x04; } 71 | 72 | $LIBFLAGS{LIBFLAG_FRESTRICTED()} = LIBFLAG_FRESTRICTED; 73 | $LIBFLAGS{LIBFLAG_FCONTROL()} = LIBFLAG_FCONTROL; 74 | $LIBFLAGS{LIBFLAG_FHIDDEN()} = LIBFLAG_FHIDDEN; 75 | 76 | # Sys Kind 77 | # -------- 78 | 79 | sub SYS_WIN16 () { 0; } 80 | sub SYS_WIN32 () { SYS_WIN16() + 1; } 81 | sub SYS_MAC () { SYS_WIN32() + 1; } 82 | 83 | $SYSKIND[SYS_WIN16] = 'SYS_WIN16'; 84 | $SYSKIND[SYS_WIN32] = 'SYS_WIN32'; 85 | $SYSKIND[SYS_MAC] = 'SYS_MAC'; 86 | 87 | # Type Flags 88 | # ---------- 89 | 90 | sub TYPEFLAG_FAPPOBJECT () { 0x1; } 91 | sub TYPEFLAG_FCANCREATE () { 0x2; } 92 | sub TYPEFLAG_FLICENSED () { 0x4; } 93 | sub TYPEFLAG_FPREDECLID () { 0x8; } 94 | sub TYPEFLAG_FHIDDEN () { 0x10; } 95 | sub TYPEFLAG_FCONTROL () { 0x20; } 96 | sub TYPEFLAG_FDUAL () { 0x40; } 97 | sub TYPEFLAG_FNONEXTENSIBLE () { 0x80; } 98 | sub TYPEFLAG_FOLEAUTOMATION () { 0x100; } 99 | sub TYPEFLAG_FRESTRICTED () { 0x200; } 100 | sub TYPEFLAG_FAGGREGATABLE () { 0x400; } 101 | sub TYPEFLAG_FREPLACEABLE () { 0x800; } 102 | sub TYPEFLAG_FDISPATCHABLE () { 0x1000; } 103 | sub TYPEFLAG_FREVERSEBIND () { 0x2000; } 104 | 105 | $TYPEFLAGS{TYPEFLAG_FAPPOBJECT()} = TYPEFLAG_FAPPOBJECT; 106 | $TYPEFLAGS{TYPEFLAG_FCANCREATE()} = TYPEFLAG_FCANCREATE; 107 | $TYPEFLAGS{TYPEFLAG_FLICENSED()} = TYPEFLAG_FLICENSED; 108 | $TYPEFLAGS{TYPEFLAG_FPREDECLID()} = TYPEFLAG_FPREDECLID; 109 | $TYPEFLAGS{TYPEFLAG_FHIDDEN()} = TYPEFLAG_FHIDDEN; 110 | $TYPEFLAGS{TYPEFLAG_FCONTROL()} = TYPEFLAG_FCONTROL; 111 | $TYPEFLAGS{TYPEFLAG_FDUAL()} = TYPEFLAG_FDUAL; 112 | $TYPEFLAGS{TYPEFLAG_FNONEXTENSIBLE()} = TYPEFLAG_FNONEXTENSIBLE; 113 | $TYPEFLAGS{TYPEFLAG_FOLEAUTOMATION()} = TYPEFLAG_FOLEAUTOMATION; 114 | $TYPEFLAGS{TYPEFLAG_FRESTRICTED()} = TYPEFLAG_FRESTRICTED; 115 | $TYPEFLAGS{TYPEFLAG_FAGGREGATABLE()} = TYPEFLAG_FAGGREGATABLE; 116 | $TYPEFLAGS{TYPEFLAG_FREPLACEABLE()} = TYPEFLAG_FREPLACEABLE; 117 | $TYPEFLAGS{TYPEFLAG_FDISPATCHABLE()} = TYPEFLAG_FDISPATCHABLE; 118 | $TYPEFLAGS{TYPEFLAG_FREVERSEBIND()} = TYPEFLAG_FREVERSEBIND; 119 | 120 | # Type Kind 121 | # --------- 122 | 123 | sub TKIND_ENUM () { 0; } 124 | sub TKIND_RECORD () { TKIND_ENUM() + 1; } 125 | sub TKIND_MODULE () { TKIND_RECORD() + 1; } 126 | sub TKIND_INTERFACE () { TKIND_MODULE() + 1; } 127 | sub TKIND_DISPATCH () { TKIND_INTERFACE() + 1; } 128 | sub TKIND_COCLASS () { TKIND_DISPATCH() + 1; } 129 | sub TKIND_ALIAS () { TKIND_COCLASS() + 1; } 130 | sub TKIND_UNION () { TKIND_ALIAS() + 1; } 131 | sub TKIND_MAX () { TKIND_UNION() + 1; } 132 | 133 | $TYPEKIND[TKIND_ENUM] = 'TKIND_ENUM'; 134 | $TYPEKIND[TKIND_RECORD] = 'TKIND_RECORD'; 135 | $TYPEKIND[TKIND_MODULE] = 'TKIND_MODULE'; 136 | $TYPEKIND[TKIND_INTERFACE] = 'TKIND_INTERFACE'; 137 | $TYPEKIND[TKIND_DISPATCH] = 'TKIND_DISPATCH'; 138 | $TYPEKIND[TKIND_COCLASS] = 'TKIND_COCLASS'; 139 | $TYPEKIND[TKIND_ALIAS] = 'TKIND_ALIAS'; 140 | $TYPEKIND[TKIND_UNION] = 'TKIND_UNION'; 141 | 142 | # Implemented Type Flags 143 | # ---------------------- 144 | 145 | sub IMPLTYPEFLAG_FDEFAULT () { 0x1; } 146 | sub IMPLTYPEFLAG_FSOURCE () { 0x2; } 147 | sub IMPLTYPEFLAG_FRESTRICTED () { 0x4; } 148 | sub IMPLTYPEFLAG_FDEFAULTVTABLE () { 0x800; } 149 | 150 | $IMPLTYPEFLAGS{IMPLTYPEFLAG_FDEFAULT()} = IMPLTYPEFLAG_FDEFAULT; 151 | $IMPLTYPEFLAGS{IMPLTYPEFLAG_FSOURCE()} = IMPLTYPEFLAG_FSOURCE; 152 | $IMPLTYPEFLAGS{IMPLTYPEFLAG_FRESTRICTED()} = IMPLTYPEFLAG_FRESTRICTED; 153 | $IMPLTYPEFLAGS{IMPLTYPEFLAG_FDEFAULTVTABLE()} = IMPLTYPEFLAG_FDEFAULTVTABLE; 154 | 155 | # Parameter Flags 156 | # --------------- 157 | 158 | sub PARAMFLAG_NONE () { 0; } 159 | sub PARAMFLAG_FIN () { 0x1; } 160 | sub PARAMFLAG_FOUT () { 0x2; } 161 | sub PARAMFLAG_FLCID () { 0x4; } 162 | sub PARAMFLAG_FRETVAL () { 0x8; } 163 | sub PARAMFLAG_FOPT () { 0x10; } 164 | sub PARAMFLAG_FHASDEFAULT () { 0x20; } 165 | 166 | $PARAMFLAGS{PARAMFLAG_NONE()} = PARAMFLAG_NONE; 167 | $PARAMFLAGS{PARAMFLAG_FIN()} = PARAMFLAG_FIN; 168 | $PARAMFLAGS{PARAMFLAG_FOUT()} = PARAMFLAG_FOUT; 169 | $PARAMFLAGS{PARAMFLAG_FLCID()} = PARAMFLAG_FLCID; 170 | $PARAMFLAGS{PARAMFLAG_FRETVAL()} = PARAMFLAG_FRETVAL; 171 | $PARAMFLAGS{PARAMFLAG_FOPT()} = PARAMFLAG_FOPT; 172 | $PARAMFLAGS{PARAMFLAG_FHASDEFAULT()} = PARAMFLAG_FHASDEFAULT; 173 | 174 | # Function Flags 175 | # -------------- 176 | 177 | sub FUNCFLAG_FRESTRICTED () { 0x1; } 178 | sub FUNCFLAG_FSOURCE () { 0x2; } 179 | sub FUNCFLAG_FBINDABLE () { 0x4; } 180 | sub FUNCFLAG_FREQUESTEDIT () { 0x8; } 181 | sub FUNCFLAG_FDISPLAYBIND () { 0x10; } 182 | sub FUNCFLAG_FDEFAULTBIND () { 0x20; } 183 | sub FUNCFLAG_FHIDDEN () { 0x40; } 184 | sub FUNCFLAG_FUSESGETLASTERROR () { 0x80; } 185 | sub FUNCFLAG_FDEFAULTCOLLELEM () { 0x100; } 186 | sub FUNCFLAG_FUIDEFAULT () { 0x200; } 187 | sub FUNCFLAG_FNONBROWSABLE () { 0x400; } 188 | sub FUNCFLAG_FREPLACEABLE () { 0x800; } 189 | sub FUNCFLAG_FIMMEDIATEBIND () { 0x1000; } 190 | 191 | $FUNCFLAGS{FUNCFLAG_FRESTRICTED()} = FUNCFLAG_FRESTRICTED; 192 | $FUNCFLAGS{FUNCFLAG_FSOURCE()} = FUNCFLAG_FSOURCE; 193 | $FUNCFLAGS{FUNCFLAG_FBINDABLE()} = FUNCFLAG_FBINDABLE; 194 | $FUNCFLAGS{FUNCFLAG_FREQUESTEDIT()} = FUNCFLAG_FREQUESTEDIT; 195 | $FUNCFLAGS{FUNCFLAG_FDISPLAYBIND()} = FUNCFLAG_FDISPLAYBIND; 196 | $FUNCFLAGS{FUNCFLAG_FDEFAULTBIND()} = FUNCFLAG_FDEFAULTBIND; 197 | $FUNCFLAGS{FUNCFLAG_FHIDDEN()} = FUNCFLAG_FHIDDEN; 198 | $FUNCFLAGS{FUNCFLAG_FUSESGETLASTERROR()} = FUNCFLAG_FUSESGETLASTERROR; 199 | $FUNCFLAGS{FUNCFLAG_FDEFAULTCOLLELEM()} = FUNCFLAG_FDEFAULTCOLLELEM; 200 | $FUNCFLAGS{FUNCFLAG_FUIDEFAULT()} = FUNCFLAG_FUIDEFAULT; 201 | $FUNCFLAGS{FUNCFLAG_FNONBROWSABLE()} = FUNCFLAG_FNONBROWSABLE; 202 | $FUNCFLAGS{FUNCFLAG_FREPLACEABLE()} = FUNCFLAG_FREPLACEABLE; 203 | $FUNCFLAGS{FUNCFLAG_FIMMEDIATEBIND()} = FUNCFLAG_FIMMEDIATEBIND; 204 | 205 | # Calling conventions 206 | # ------------------- 207 | 208 | sub CC_FASTCALL () { 0; } 209 | sub CC_CDECL () { 1; } 210 | sub CC_MSCPASCAL () { CC_CDECL() + 1; } 211 | sub CC_PASCAL () { CC_MSCPASCAL; } 212 | sub CC_MACPASCAL () { CC_PASCAL() + 1; } 213 | sub CC_STDCALL () { CC_MACPASCAL() + 1; } 214 | sub CC_FPFASTCALL () { CC_STDCALL() + 1; } 215 | sub CC_SYSCALL () { CC_FPFASTCALL() + 1; } 216 | sub CC_MPWCDECL () { CC_SYSCALL() + 1; } 217 | sub CC_MPWPASCAL () { CC_MPWCDECL() + 1; } 218 | sub CC_MAX () { CC_MPWPASCAL() + 1; } 219 | 220 | $CALLCONV[CC_FASTCALL] = 'CC_FASTCALL'; 221 | $CALLCONV[CC_CDECL] = 'CC_CDECL'; 222 | $CALLCONV[CC_PASCAL] = 'CC_PASCAL'; 223 | $CALLCONV[CC_MACPASCAL] = 'CC_MACPASCAL'; 224 | $CALLCONV[CC_STDCALL] = 'CC_STDCALL'; 225 | $CALLCONV[CC_FPFASTCALL] = 'CC_FPFASTCALL'; 226 | $CALLCONV[CC_SYSCALL] = 'CC_SYSCALL'; 227 | $CALLCONV[CC_MPWCDECL] = 'CC_MPWCDECL'; 228 | $CALLCONV[CC_MPWPASCAL] = 'CC_MPWPASCAL'; 229 | 230 | # Function Kind 231 | # ------------- 232 | 233 | sub FUNC_VIRTUAL () { 0; } 234 | sub FUNC_PUREVIRTUAL () { FUNC_VIRTUAL() + 1; } 235 | sub FUNC_NONVIRTUAL () { FUNC_PUREVIRTUAL() + 1; } 236 | sub FUNC_STATIC () { FUNC_NONVIRTUAL() + 1; } 237 | sub FUNC_DISPATCH () { FUNC_STATIC() + 1; } 238 | 239 | $FUNCKIND[FUNC_VIRTUAL] = 'FUNC_VIRTUAL'; 240 | $FUNCKIND[FUNC_PUREVIRTUAL] = 'FUNC_PUREVIRTUAL'; 241 | $FUNCKIND[FUNC_NONVIRTUAL] = 'FUNC_NONVIRTUAL'; 242 | $FUNCKIND[FUNC_STATIC] = 'FUNC_STATIC'; 243 | $FUNCKIND[FUNC_DISPATCH] = 'FUNC_DISPATCH'; 244 | 245 | # Invoke Kind 246 | # ----------- 247 | 248 | sub INVOKE_FUNC () { 1; } 249 | sub INVOKE_PROPERTYGET () { 2; } 250 | sub INVOKE_PROPERTYPUT () { 4; } 251 | sub INVOKE_PROPERTYPUTREF () { 8; } 252 | 253 | $INVOKEKIND{INVOKE_FUNC()} = INVOKE_FUNC; 254 | $INVOKEKIND{INVOKE_PROPERTYGET()} = INVOKE_PROPERTYGET; 255 | $INVOKEKIND{INVOKE_PROPERTYPUT()} = INVOKE_PROPERTYPUT; 256 | $INVOKEKIND{INVOKE_PROPERTYPUTREF()} = INVOKE_PROPERTYPUTREF; 257 | 258 | # Variable Flags 259 | # -------------- 260 | 261 | sub VARFLAG_FREADONLY () { 0x1; } 262 | sub VARFLAG_FSOURCE () { 0x2; } 263 | sub VARFLAG_FBINDABLE () { 0x4; } 264 | sub VARFLAG_FREQUESTEDIT () { 0x8; } 265 | sub VARFLAG_FDISPLAYBIND () { 0x10; } 266 | sub VARFLAG_FDEFAULTBIND () { 0x20; } 267 | sub VARFLAG_FHIDDEN () { 0x40; } 268 | sub VARFLAG_FRESTRICTED () { 0x80; } 269 | sub VARFLAG_FDEFAULTCOLLELEM () { 0x100; } 270 | sub VARFLAG_FUIDEFAULT () { 0x200; } 271 | sub VARFLAG_FNONBROWSABLE () { 0x400; } 272 | sub VARFLAG_FREPLACEABLE () { 0x800; } 273 | sub VARFLAG_FIMMEDIATEBIND () { 0x1000; } 274 | 275 | $VARFLAGS{VARFLAG_FREADONLY()} = VARFLAG_FREADONLY; 276 | $VARFLAGS{VARFLAG_FSOURCE()} = VARFLAG_FSOURCE; 277 | $VARFLAGS{VARFLAG_FBINDABLE()} = VARFLAG_FBINDABLE; 278 | $VARFLAGS{VARFLAG_FREQUESTEDIT()} = VARFLAG_FREQUESTEDIT; 279 | $VARFLAGS{VARFLAG_FDISPLAYBIND()} = VARFLAG_FDISPLAYBIND; 280 | $VARFLAGS{VARFLAG_FDEFAULTBIND()} = VARFLAG_FDEFAULTBIND; 281 | $VARFLAGS{VARFLAG_FHIDDEN()} = VARFLAG_FHIDDEN; 282 | $VARFLAGS{VARFLAG_FRESTRICTED()} = VARFLAG_FRESTRICTED; 283 | $VARFLAGS{VARFLAG_FDEFAULTCOLLELEM()} = VARFLAG_FDEFAULTCOLLELEM; 284 | $VARFLAGS{VARFLAG_FUIDEFAULT()} = VARFLAG_FUIDEFAULT; 285 | $VARFLAGS{VARFLAG_FNONBROWSABLE()} = VARFLAG_FNONBROWSABLE; 286 | $VARFLAGS{VARFLAG_FREPLACEABLE()} = VARFLAG_FREPLACEABLE; 287 | $VARFLAGS{VARFLAG_FIMMEDIATEBIND()} = VARFLAG_FIMMEDIATEBIND; 288 | 289 | 290 | # Variant Types 291 | # ------------- 292 | 293 | sub VT_EMPTY () { 0; } 294 | sub VT_NULL () { 1; } 295 | sub VT_I2 () { 2; } 296 | sub VT_I4 () { 3; } 297 | sub VT_R4 () { 4; } 298 | sub VT_R8 () { 5; } 299 | sub VT_CY () { 6; } 300 | sub VT_DATE () { 7; } 301 | sub VT_BSTR () { 8; } 302 | sub VT_DISPATCH () { 9; } 303 | sub VT_ERROR () { 10; } 304 | sub VT_BOOL () { 11; } 305 | sub VT_VARIANT () { 12; } 306 | sub VT_UNKNOWN () { 13; } 307 | sub VT_DECIMAL () { 14; } 308 | sub VT_I1 () { 16; } 309 | sub VT_UI1 () { 17; } 310 | sub VT_UI2 () { 18; } 311 | sub VT_UI4 () { 19; } 312 | sub VT_I8 () { 20; } 313 | sub VT_UI8 () { 21; } 314 | sub VT_INT () { 22; } 315 | sub VT_UINT () { 23; } 316 | sub VT_VOID () { 24; } 317 | sub VT_HRESULT () { 25; } 318 | sub VT_PTR () { 26; } 319 | sub VT_SAFEARRAY () { 27; } 320 | sub VT_CARRAY () { 28; } 321 | sub VT_USERDEFINED () { 29; } 322 | sub VT_LPSTR () { 30; } 323 | sub VT_LPWSTR () { 31; } 324 | sub VT_FILETIME () { 64; } 325 | sub VT_BLOB () { 65; } 326 | sub VT_STREAM () { 66; } 327 | sub VT_STORAGE () { 67; } 328 | sub VT_STREAMED_OBJECT () { 68; } 329 | sub VT_STORED_OBJECT () { 69; } 330 | sub VT_BLOB_OBJECT () { 70; } 331 | sub VT_CF () { 71; } 332 | sub VT_CLSID () { 72; } 333 | sub VT_VECTOR () { 0x1000; } 334 | sub VT_ARRAY () { 0x2000; } 335 | sub VT_BYREF () { 0x4000; } 336 | sub VT_RESERVED () { 0x8000; } 337 | sub VT_ILLEGAL () { 0xffff; } 338 | sub VT_ILLEGALMASKED () { 0xfff; } 339 | sub VT_TYPEMASK () { 0xfff; } 340 | 341 | $VT[VT_EMPTY] = 'VT_EMPTY'; 342 | $VT[VT_NULL] = 'VT_NULL'; 343 | $VT[VT_I2] = 'VT_I2'; 344 | $VT[VT_I4] = 'VT_I4'; 345 | $VT[VT_R4] = 'VT_R4'; 346 | $VT[VT_R8] = 'VT_R8'; 347 | $VT[VT_CY] = 'VT_CY'; 348 | $VT[VT_DATE] = 'VT_DATE'; 349 | $VT[VT_BSTR] = 'VT_BSTR'; 350 | $VT[VT_DISPATCH] = 'VT_DISPATCH'; 351 | $VT[VT_ERROR] = 'VT_ERROR'; 352 | $VT[VT_BOOL] = 'VT_BOOL'; 353 | $VT[VT_VARIANT] = 'VT_VARIANT'; 354 | $VT[VT_UNKNOWN] = 'VT_UNKNOWN'; 355 | $VT[VT_DECIMAL] = 'VT_DECIMAL'; 356 | $VT[VT_I1] = 'VT_I1'; 357 | $VT[VT_UI1] = 'VT_UI1'; 358 | $VT[VT_UI2] = 'VT_UI2'; 359 | $VT[VT_UI4] = 'VT_UI4'; 360 | $VT[VT_I8] = 'VT_I8'; 361 | $VT[VT_UI8] = 'VT_UI8'; 362 | $VT[VT_INT] = 'VT_INT'; 363 | $VT[VT_UINT] = 'VT_UINT'; 364 | $VT[VT_VOID] = 'VT_VOID'; 365 | $VT[VT_HRESULT] = 'VT_HRESULT'; 366 | $VT[VT_PTR] = 'VT_PTR'; 367 | $VT[VT_SAFEARRAY] = 'VT_SAFEARRAY'; 368 | $VT[VT_CARRAY] = 'VT_CARRAY'; 369 | $VT[VT_USERDEFINED] = 'VT_USERDEFINED'; 370 | $VT[VT_LPSTR] = 'VT_LPSTR'; 371 | $VT[VT_LPWSTR] = 'VT_LPWSTR'; 372 | $VT[VT_FILETIME] = 'VT_FILETIME'; 373 | $VT[VT_BLOB] = 'VT_BLOB'; 374 | $VT[VT_STREAM] = 'VT_STREAM'; 375 | $VT[VT_STORAGE] = 'VT_STORAGE'; 376 | $VT[VT_STREAMED_OBJECT] = 'VT_STREAMED_OBJECT'; 377 | $VT[VT_STORED_OBJECT] = 'VT_STORED_OBJECT'; 378 | $VT[VT_BLOB_OBJECT] = 'VT_BLOB_OBJECT'; 379 | $VT[VT_CF] = 'VT_CF'; 380 | $VT[VT_CLSID] = 'VT_CLSID'; 381 | $VT[VT_VECTOR] = 'VT_VECTOR'; 382 | $VT[VT_ARRAY] = 'VT_ARRAY'; 383 | $VT[VT_BYREF] = 'VT_BYREF'; 384 | $VT[VT_RESERVED] = 'VT_RESERVED'; 385 | $VT[VT_ILLEGAL] = 'VT_ILLEGAL'; 386 | $VT[VT_ILLEGALMASKED] = 'VT_ILLEGALMASKED'; 387 | $VT[VT_TYPEMASK] = 'VT_TYPEMASK'; 388 | 389 | 1; 390 | -------------------------------------------------------------------------------- /lib/Win32/OLE/Variant.pm: -------------------------------------------------------------------------------- 1 | # The documentation is at the __END__ 2 | 3 | package Win32::OLE::Variant; 4 | require Win32::OLE; # Make sure the XS bootstrap has been called 5 | 6 | use strict; 7 | use vars qw(@ISA @EXPORT @EXPORT_OK); 8 | 9 | use Exporter; 10 | @ISA = qw(Exporter); 11 | 12 | @EXPORT = qw( 13 | Variant 14 | VT_EMPTY VT_NULL VT_I2 VT_I4 VT_R4 VT_R8 VT_CY VT_DATE VT_BSTR 15 | VT_DISPATCH VT_ERROR VT_BOOL VT_VARIANT VT_UNKNOWN VT_DECIMAL VT_UI1 16 | VT_ARRAY VT_BYREF 17 | ); 18 | 19 | @EXPORT_OK = qw(CP_ACP CP_OEMCP nothing nullstring); 20 | 21 | # Automation data types. 22 | sub VT_EMPTY {0;} 23 | sub VT_NULL {1;} 24 | sub VT_I2 {2;} 25 | sub VT_I4 {3;} 26 | sub VT_R4 {4;} 27 | sub VT_R8 {5;} 28 | sub VT_CY {6;} 29 | sub VT_DATE {7;} 30 | sub VT_BSTR {8;} 31 | sub VT_DISPATCH {9;} 32 | sub VT_ERROR {10;} 33 | sub VT_BOOL {11;} 34 | sub VT_VARIANT {12;} 35 | sub VT_UNKNOWN {13;} 36 | sub VT_DECIMAL {14;} # Officially not allowed in VARIANTARGs 37 | sub VT_UI1 {17;} 38 | 39 | sub VT_ARRAY {0x2000;} 40 | sub VT_BYREF {0x4000;} 41 | 42 | 43 | # For backward compatibility 44 | sub CP_ACP {0;} # ANSI codepage 45 | sub CP_OEMCP {1;} # OEM codepage 46 | 47 | use overload 48 | # '+' => 'Add', '-' => 'Sub', '*' => 'Mul', '/' => 'Div', 49 | '""' => sub {$_[0]->As(VT_BSTR)}, 50 | '0+' => sub {$_[0]->As(VT_R8)}, 51 | fallback => 1; 52 | 53 | sub Variant { 54 | return Win32::OLE::Variant->new(@_); 55 | } 56 | 57 | sub nothing { 58 | return Win32::OLE::Variant->new(VT_DISPATCH); 59 | } 60 | 61 | sub nullstring { 62 | return Win32::OLE::Variant->new(VT_BSTR); 63 | } 64 | 65 | 1; 66 | 67 | __END__ 68 | 69 | =head1 NAME 70 | 71 | Win32::OLE::Variant - Create and modify OLE VARIANT variables 72 | 73 | =head1 SYNOPSIS 74 | 75 | use Win32::OLE::Variant; 76 | my $var = Variant(VT_DATE, 'Jan 1,1970'); 77 | $OleObject->{value} = $var; 78 | $OleObject->Method($var); 79 | 80 | 81 | =head1 DESCRIPTION 82 | 83 | The IDispatch interface used by the Perl OLE module uses a universal 84 | argument type called VARIANT. This is basically an object containing 85 | a data type and the actual data value. The data type is specified by 86 | the VT_xxx constants. 87 | 88 | =head2 Functions 89 | 90 | =over 8 91 | 92 | =item nothing() 93 | 94 | The nothing() function returns an empty VT_DISPATCH variant. It can be 95 | used to clear an object reference stored in a property 96 | 97 | use Win32::OLE::Variant qw(:DEFAULT nothing); 98 | # ... 99 | $object->{Property} = nothing; 100 | 101 | This has the same effect as the Visual Basic statement 102 | 103 | Set object.Property = Nothing 104 | 105 | The nothing() function is B exported by default. 106 | 107 | =item nullstring() 108 | 109 | The nullstring() function returns a VT_BSTR variant with a NULL string 110 | pointer. This is B the same as a VT_BSTR variant with an empty 111 | string "". The nullstring() value is the same as the vbNullString 112 | constant in Visual Basic. 113 | 114 | The nullstring() function is B exported by default. 115 | 116 | =item Variant(TYPE, DATA) 117 | 118 | This is just a function alias of the Cnew()> 119 | method (see below). This function is exported by default. 120 | 121 | =back 122 | 123 | =head2 Methods 124 | 125 | =over 8 126 | 127 | =item new(TYPE, DATA) 128 | 129 | This method returns a Win32::OLE::Variant object of the specified 130 | TYPE that contains the given DATA. The Win32::OLE::Variant object 131 | can be used to specify data types other than IV, NV or PV (which are 132 | supported transparently). See L below for details. 133 | 134 | For VT_EMPTY and VT_NULL variants, the DATA argument may be omitted. 135 | For all non-VT_ARRAY variants DATA specifies the initial value. 136 | 137 | To create a SAFEARRAY variant, you have to specify the VT_ARRAY flag in 138 | addition to the variant base type of the array elements. In this cases 139 | DATA must be a list specifying the dimensions of the array. Each element 140 | can be either an element count (indices 0 to count-1) or an array 141 | reference pointing to the lower and upper array bounds of this dimension: 142 | 143 | my $Array = Win32::OLE::Variant->new(VT_ARRAY|VT_R8, [1,2], 2); 144 | 145 | This creates a 2-dimensional SAFEARRAY of doubles with 4 elements: 146 | (1,0), (1,1), (2,0) and (2,1). 147 | 148 | A special case is the creation of one-dimensional VT_UI1 arrays with 149 | a string DATA argument: 150 | 151 | my $String = Variant(VT_ARRAY|VT_UI1, "String"); 152 | 153 | This creates a 6 element character array initialized to "String". For 154 | backward compatibility VT_UI1 with a string initializer automatically 155 | implies VT_ARRAY. The next line is equivalent to the previous example: 156 | 157 | my $String = Variant(VT_UI1, "String"); 158 | 159 | If you really need a single character VT_UI1 variant, you have to create 160 | it using a numeric intializer: 161 | 162 | my $Char = Variant(VT_UI1, ord('A')); 163 | 164 | =item As(TYPE) 165 | 166 | C converts the VARIANT to the new type before converting to a 167 | Perl value. This take the current LCID setting into account. For 168 | example a string might contain a ',' as the decimal point character. 169 | Using C<$variant->As(VT_R8)> will correctly return the floating 170 | point value. 171 | 172 | The underlying variant object is NOT changed by this method. 173 | 174 | =item ChangeType(TYPE) 175 | 176 | This method changes the type of the contained VARIANT in place. It 177 | returns the object itself, not the converted value. 178 | 179 | =item Copy([DIM]) 180 | 181 | This method creates a copy of the object. If the original variant had 182 | the VT_BYREF bit set then the new object will contain a copy of the 183 | referenced data and not a reference to the same old data. The new 184 | object will not have the VT_BYREF bit set. 185 | 186 | my $Var = Variant(VT_I4|VT_ARRAY|VT_BYREF, [1,5], 3); 187 | my $Copy = $Var->Copy; 188 | 189 | The type of C<$Copy> is now VT_I4|VT_ARRAY and the value is a copy of 190 | the other SAFEARRAY. Changes to elements of C<$Var> will not be reflected 191 | in C<$Copy> and vice versa. 192 | 193 | The C method can also be used to extract a single element of a 194 | VT_ARRAY | VT_VARIANT object. In this case the array indices must be 195 | specified as a list DIM: 196 | 197 | my $Int = $Var->Copy(1, 2); 198 | 199 | C<$Int> is now a VT_I4 Variant object containing the value of element (1,2). 200 | 201 | =item Currency([FORMAT[, LCID]]) 202 | 203 | This method converts the VARIANT value into a formatted currency string. The 204 | FORMAT can be either an integer constant or a hash reference. Valid constants 205 | are 0 and LOCALE_NOUSEROVERRIDE. You get the value of LOCALE_NOUSEROVERRIDE 206 | from the Win32::OLE::NLS module: 207 | 208 | use Win32::OLE::NLS qw(:LOCALE); 209 | 210 | LOCALE_NOUSEROVERRIDE tells the method to use the system default currency 211 | format for the specified locale, disregarding any changes that might have 212 | been made through the control panel application. 213 | 214 | The hash reference could contain the following keys: 215 | 216 | NumDigits number of fractional digits 217 | LeadingZero whether to use leading zeroes in decimal fields 218 | Grouping size of each group of digits to the left of the decimal 219 | DecimalSep decimal separator string 220 | ThousandSep thousand separator string 221 | NegativeOrder see L 222 | PositiveOrder see L 223 | CurrencySymbol currency symbol string 224 | 225 | For example: 226 | 227 | use Win32::OLE::Variant; 228 | use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG :DATE :TIME); 229 | my $lcidGerman = MAKELCID(MAKELANGID(LANG_GERMAN, SUBLANG_NEUTRAL)); 230 | my $v = Variant(VT_CY, "-922337203685477.5808"); 231 | print $v->Currency({CurrencySymbol => "Tuits"}, $lcidGerman), "\n"; 232 | 233 | will print: 234 | 235 | -922.337.203.685.477,58 Tuits 236 | 237 | =item Date([FORMAT[, LCID]]) 238 | 239 | Converts the VARIANT into a formatted date string. FORMAT can be either 240 | one of the following integer constants or a format string: 241 | 242 | LOCALE_NOUSEROVERRIDE system default date format for this locale 243 | DATE_SHORTDATE use the short date format (default) 244 | DATE_LONGDATE use the long date format 245 | DATE_YEARMONTH use the year/month format 246 | DATE_USE_ALT_CALENDAR use the alternate calendar, if one exists 247 | DATE_LTRREADING left-to-right reading order layout 248 | DATE_RTLREADING right-to left reading order layout 249 | 250 | The constants are available from the Win32::OLE::NLS module: 251 | 252 | use Win32::OLE::NLS qw(:LOCALE :DATE); 253 | 254 | The following elements can be used to construct a date format string. 255 | Characters must be specified exactly as given below (e.g. "dd" B "DD"). 256 | Spaces can be inserted anywhere between formatting codes, other verbatim 257 | text should be included in single quotes. 258 | 259 | d day of month 260 | dd day of month with leading zero for single-digit days 261 | ddd day of week: three-letter abbreviation (LOCALE_SABBREVDAYNAME) 262 | dddd day of week: full name (LOCALE_SDAYNAME) 263 | M month 264 | MM month with leading zero for single-digit months 265 | MMM month: three-letter abbreviation (LOCALE_SABBREVMONTHNAME) 266 | MMMM month: full name (LOCALE_SMONTHNAME) 267 | y year as last two digits 268 | yy year as last two digits with leading zero for years less than 10 269 | yyyy year represented by full four digits 270 | gg period/era string 271 | 272 | For example: 273 | 274 | my $v = Variant(VT_DATE, "April 1 99"); 275 | print $v->Date(DATE_LONGDATE), "\n"; 276 | print $v->Date("ddd',' MMM dd yy"), "\n"; 277 | 278 | will print: 279 | 280 | Thursday, April 01, 1999 281 | Thu, Apr 01 99 282 | 283 | =item Dim() 284 | 285 | Returns a list of array bounds for a VT_ARRAY variant. The list contains 286 | an array reference for each dimension of the variant's SAFEARRAY. This 287 | reference points to an array containing the lower and upper bounds for 288 | this dimension. For example: 289 | 290 | my @Dim = $Var->Dim; 291 | 292 | Now C<@Dim> contains the following list: C<([1,5], [0,2])>. 293 | 294 | =item Get(DIM) 295 | 296 | For normal variants C returns the value of the variant, just like the 297 | C method. For VT_ARRAY variants C retrieves the value of a single 298 | array element. In this case C must be a list of array indices. E.g. 299 | 300 | my $Val = $Var->Get(2,0); 301 | 302 | As a special case for one dimensional VT_UI1|VT_ARRAY variants the C 303 | method without arguments returns the character array as a Perl string. 304 | 305 | print $String->Get, "\n"; 306 | 307 | =item IsNothing() 308 | 309 | Tests if the object is an empty VT_DISPATCH variant. See also nothing(). 310 | 311 | =item IsNullString() 312 | 313 | Tests if the object is an empty VT_BSTR variant. See also nullstring(). 314 | 315 | =item LastError() 316 | 317 | The use of the CLastError()> method is deprecated. 318 | Please use the CLastError()> class method instead. 319 | 320 | =item Number([FORMAT[, LCID]]) 321 | 322 | This method converts the VARIANT value into a formatted number string. The 323 | FORMAT can be either an integer constant or a hash reference. Valid constants 324 | are 0 and LOCALE_NOUSEROVERRIDE. You get the value of LOCALE_NOUSEROVERRIDE 325 | from the Win32::OLE::NLS module: 326 | 327 | use Win32::OLE::NLS qw(:LOCALE); 328 | 329 | LOCALE_NOUSEROVERRIDE tells the method to use the system default number 330 | format for the specified locale, disregarding any changes that might have 331 | been made through the control panel application. 332 | 333 | The hash reference could contain the following keys: 334 | 335 | NumDigits number of fractional digits 336 | LeadingZero whether to use leading zeroes in decimal fields 337 | Grouping size of each group of digits to the left of the decimal 338 | DecimalSep decimal separator string 339 | ThousandSep thousand separator string 340 | NegativeOrder see L 341 | 342 | =item Put(DIM, VALUE) 343 | 344 | The C method is used to assign a new value to a variant. The value will 345 | be coerced into the current type of the variant. E.g.: 346 | 347 | my $Var = Variant(VT_I4, 42); 348 | $Var->Put(3.1415); 349 | 350 | This changes the value of the variant to C<3> because the type is VT_I4. 351 | 352 | For VT_ARRAY type variants the indices for each dimension of the contained 353 | SAFEARRAY must be specified in front of the new value: 354 | 355 | $Array->Put(1, 1, 2.7); 356 | 357 | It is also possible to assign values to *every* element of the SAFEARRAY at 358 | once using a single Put() method call: 359 | 360 | $Array->Put([[1,2], [3,4]]); 361 | 362 | In this case the argument to Put() must be an array reference and the 363 | dimensions of the Perl list-of-lists must match the dimensions of the 364 | SAFEARRAY exactly. 365 | 366 | The are a few special cases for one-dimensional VT_UI1 arrays: The VALUE 367 | can be specified as a string instead of a number. This will set the selected 368 | character to the first character of the string or to '\0' if the string was 369 | empty: 370 | 371 | my $String = Variant(VT_UI1|VT_ARRAY, "ABCDE"); 372 | $String->Put(1, "123"); 373 | $String->Put(3, ord('Z')); 374 | $String->Put(4, ''); 375 | 376 | This will set the value of C<$String> to C<"A1CZ\0">. If the index is omitted 377 | then the string is copied to the value completely. The string is truncated 378 | if it is longer than the size of the VT_UI1 array. The result will be padded 379 | with '\0's if the string is shorter: 380 | 381 | $String->Put("String"); 382 | 383 | Now C<$String> contains the value "Strin". 384 | 385 | C returns the Variant object itself so that multiple C calls can be 386 | chained together: 387 | 388 | $Array->Put(0,0,$First_value)->Put(0,1,$Another_value); 389 | 390 | =item Time([FORMAT[, LCID]]) 391 | 392 | Converts the VARIANT into a formatted time string. FORMAT can be either 393 | one of the following integer constants or a format string: 394 | 395 | LOCALE_NOUSEROVERRIDE system default time format for this locale 396 | TIME_NOMINUTESORSECONDS don't use minutes or seconds 397 | TIME_NOSECONDS don't use seconds 398 | TIME_NOTIMEMARKER don't use a time marker 399 | TIME_FORCE24HOURFORMAT always use a 24-hour time format 400 | 401 | The constants are available from the Win32::OLE::NLS module: 402 | 403 | use Win32::OLE::NLS qw(:LOCALE :TIME); 404 | 405 | The following elements can be used to construct a time format string. 406 | Characters must be specified exactly as given below (e.g. "dd" B "DD"). 407 | Spaces can be inserted anywhere between formatting codes, other verbatim 408 | text should be included in single quotes. 409 | 410 | h hours; 12-hour clock 411 | hh hours with leading zero for single-digit hours; 12-hour clock 412 | H hours; 24-hour clock 413 | HH hours with leading zero for single-digit hours; 24-hour clock 414 | m minutes 415 | mm minutes with leading zero for single-digit minutes 416 | s seconds 417 | ss seconds with leading zero for single-digit seconds 418 | t one character time marker string, such as A or P 419 | tt multicharacter time marker string, such as AM or PM 420 | 421 | For example: 422 | 423 | my $v = Variant(VT_DATE, "April 1 99 2:23 pm"); 424 | print $v->Time, "\n"; 425 | print $v->Time(TIME_FORCE24HOURFORMAT|TIME_NOTIMEMARKER), "\n"; 426 | print $v->Time("hh.mm.ss tt"), "\n"; 427 | 428 | will print: 429 | 430 | 2:23:00 PM 431 | 14:23:00 432 | 02.23.00 PM 433 | 434 | =item Type() 435 | 436 | The C method returns the variant type of the contained VARIANT. 437 | 438 | =item Unicode() 439 | 440 | The C method returns a C object. This contains 441 | the BSTR value of the variant in network byte order. If the variant is 442 | not currently in VT_BSTR format then a VT_BSTR copy will be produced first. 443 | 444 | =item Value() 445 | 446 | The C method returns the value of the VARIANT as a Perl value. The 447 | conversion is performed in the same manner as all return values of 448 | Win32::OLE method calls are converted. 449 | 450 | =back 451 | 452 | =head2 Overloading 453 | 454 | The Win32::OLE::Variant package has overloaded the conversion to 455 | string and number formats. Therefore variant objects can be used in 456 | arithmetic and string operations without applying the C 457 | method first. 458 | 459 | =head2 Class Variables 460 | 461 | The Win32::OLE::Variant class used to have its own set of class variables 462 | like C<$CP>, C<$LCID> and C<$Warn>. In version 0.1003 and later of the 463 | Win32::OLE module these variables have been eliminated. Now the settings 464 | of Win32::OLE are used by the Win32::OLE::Variant module too. Please read 465 | the documentation of the C class method. 466 | 467 | 468 | =head2 Constants 469 | 470 | These constants are exported by default: 471 | 472 | VT_EMPTY 473 | VT_NULL 474 | VT_I2 475 | VT_I4 476 | VT_R4 477 | VT_R8 478 | VT_CY 479 | VT_DATE 480 | VT_BSTR 481 | VT_DISPATCH 482 | VT_ERROR 483 | VT_BOOL 484 | VT_VARIANT 485 | VT_UNKNOWN 486 | VT_DECIMAL 487 | VT_UI1 488 | 489 | VT_ARRAY 490 | VT_BYREF 491 | 492 | VT_DECIMAL is not on the official list of allowable OLE Automation 493 | datatypes. But even Microsoft ADO seems to sometimes return values 494 | of Recordset fields in VT_DECIMAL format. 495 | 496 | =head2 Variants 497 | 498 | A Variant is a data type that is used to pass data between OLE 499 | connections. 500 | 501 | The default behavior is to convert each perl scalar variable into 502 | an OLE Variant according to the internal perl representation. 503 | The following type correspondence holds: 504 | 505 | C type Perl type OLE type 506 | ------ --------- -------- 507 | int IV VT_I4 508 | double NV VT_R8 509 | char * PV VT_BSTR 510 | void * ref to AV VT_ARRAY 511 | ? undef VT_ERROR 512 | ? Win32::OLE object VT_DISPATCH 513 | 514 | Note that VT_BSTR is a wide character or Unicode string. This presents a 515 | problem if you want to pass in binary data as a parameter as 0x00 is 516 | inserted between all the bytes in your data. The C method 517 | provides a solution to this. With Variants the script writer can specify 518 | the OLE variant type that the parameter should be converted to. Currently 519 | supported types are: 520 | 521 | VT_UI1 unsigned char 522 | VT_I2 signed int (2 bytes) 523 | VT_I4 signed int (4 bytes) 524 | VT_R4 float (4 bytes) 525 | VT_R8 float (8 bytes) 526 | VT_DATE OLE Date 527 | VT_BSTR OLE String 528 | VT_CY OLE Currency 529 | VT_BOOL OLE Boolean 530 | 531 | When VT_DATE and VT_CY objects are created, the input parameter is treated 532 | as a Perl string type, which is then converted to VT_BSTR, and finally to 533 | VT_DATE of VT_CY using the C OLE API function. 534 | See L for how these types can be used. 535 | 536 | =head2 Variant arrays 537 | 538 | A variant can not only contain a single value but also a multi-dimensional 539 | array of values (called a SAFEARRAY). In this case the VT_ARRAY flag must 540 | be added to the base variant type, e.g. C for an array of 541 | integers. The VT_EMPTY and VT_NULL types are invalid for SAFEARRAYs. It 542 | is possible to create an array of variants: C. In this 543 | case each element of the array can have a different type (including VT_EMPTY 544 | and VT_NULL). The elements of a VT_VARIANT SAFEARRAY cannot have either of the 545 | VT_ARRAY or VT_BYREF flags set. 546 | 547 | The lower and upper bounds for each dimension can be specified separately. 548 | They do not have to have all the same lower bound (unlike Perl's arrays). 549 | 550 | =head2 Variants by reference 551 | 552 | Some OLE servers expect parameters passed by reference so that they 553 | can be changed in the method call. This allows methods to easily 554 | return multiple values. There is preliminary support for this in 555 | the Win32::OLE::Variant module: 556 | 557 | my $x = Variant(VT_I4|VT_BYREF, 0); 558 | my $y = Variant(VT_I4|VT_BYREF, 0); 559 | $Corel->GetSize($x, $y); 560 | print "Size is $x by $y\n"; 561 | 562 | After the C method call C<$x> and C<$y> will be set to 563 | the respective sizes. They will still be variants. In the print 564 | statement the overloading converts them to string representation 565 | automatically. 566 | 567 | VT_BYREF is now supported for all variant types (including SAFEARRAYs). 568 | It can also be used to pass an OLE object by reference: 569 | 570 | my $Results = $App->CreateResultsObject; 571 | $Object->Method(Variant(VT_DISPATCH|VT_BYREF, $Results)); 572 | 573 | =head1 AUTHORS/COPYRIGHT 574 | 575 | This module is part of the Win32::OLE distribution. 576 | 577 | =cut 578 | -------------------------------------------------------------------------------- /t/1_nls.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # 3 | # Test of Win32::OLE::NLS 4 | # 5 | ######################################################################## 6 | # If you rearrange the tests, please renumber: 7 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 1_nls.t 8 | ######################################################################## 9 | 10 | use strict; 11 | use FileHandle; 12 | use Win32::OLE::NLS qw(/./); 13 | 14 | $^W = 1; 15 | STDOUT->autoflush(1); 16 | STDERR->autoflush(1); 17 | 18 | open(ME,$0) or die $!; 19 | my $TestCount = grep(/\+\+\$Test/,); 20 | close(ME); 21 | 22 | my $Test = 0; 23 | print "1..$TestCount\n"; 24 | 25 | # 1. Create English locale identifier 26 | my $langID = MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL); 27 | my $lcid = MAKELCID($langID); 28 | print "not " unless $lcid == 9; 29 | printf "ok %d\n", ++$Test; 30 | 31 | # 2. Query "English name of language" 32 | print "not " unless GetLocaleInfo($lcid,LOCALE_SENGLANGUAGE) eq "English"; 33 | printf "ok %d\n", ++$Test; 34 | 35 | -------------------------------------------------------------------------------- /t/2_variant.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # 3 | # Test of Win32::OLE::Variant 4 | # 5 | ######################################################################## 6 | # If you rearrange the tests, please renumber: 7 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 2_variant.t 8 | ######################################################################## 9 | 10 | use strict; 11 | use FileHandle; 12 | use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG :DATE :TIME); 13 | use Win32::OLE::Variant qw(:DEFAULT CP_ACP nothing nullstring); 14 | 15 | $^W = 1; 16 | STDOUT->autoflush(1); 17 | STDERR->autoflush(1); 18 | 19 | open(ME,$0) or die $!; 20 | my $TestCount = grep(/\+\+\$Test/,); 21 | close(ME); 22 | 23 | my $Test = 0; 24 | print "1..$TestCount\n"; 25 | 26 | my $lcidEnglish = MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL)); 27 | my $lcidGerman = MAKELCID(MAKELANGID(LANG_GERMAN, SUBLANG_NEUTRAL)); 28 | 29 | Win32::OLE->Option(CP => CP_ACP, LCID => $lcidEnglish); 30 | printf "# LCID is %d\n", Win32::OLE->Option('LCID'); 31 | printf "# CP is %d\n", Win32::OLE->Option('CP'); 32 | 33 | # 1. Create a simple numeric variant 34 | my $v = Variant(VT_R8, 3.1415); 35 | print "not " unless UNIVERSAL::isa($v, 'Win32::OLE::Variant'); 36 | printf "ok %d\n", ++$Test; 37 | 38 | # 2. Verify type and value of variant 39 | printf "# Type is %d and Value is %f\n", $v->Type, $v->Value; 40 | print "not " unless $v->Type == VT_R8 && $v->Value == 3.1415; 41 | printf "ok %d\n", ++$Test; 42 | 43 | # 3. Retrieve value as VT_BSTR value 44 | printf "# As(VT_BSTR) is \"%s\"\n", $v->As(VT_BSTR); 45 | print "not " unless $v->As(VT_BSTR) eq "3.1415"; 46 | printf "ok %d\n", ++$Test; 47 | 48 | # 4. Change locale to "German" (uses ',' as decimal point) 49 | Win32::OLE->Option(LCID => $lcidGerman); 50 | printf "# As(VT_BSTR) in lcid=$lcidGerman is \"%s\"\n", $v->As(VT_BSTR); 51 | print "not " unless $v->Value == 3.1415 && $v->As(VT_BSTR) eq "3,1415"; 52 | printf "ok %d\n", ++$Test; 53 | 54 | # 5. Backward compatibility: direct access to class variables 55 | printf "# Win32::OLE::LCID=%d\n", $Win32::OLE::LCID; 56 | print "not " unless $Win32::OLE::LCID == Win32::OLE->Option('LCID'); 57 | printf "ok %d\n", ++$Test; 58 | 59 | # 6. Test overloaded conversion to string 60 | printf "# String value is \"$v\"\n"; 61 | print "not " unless "$v" eq "3,1415"; 62 | printf "ok %d\n", ++$Test; 63 | 64 | # 7. Test overloaded conversion to number 65 | printf "# Numeric (0) value is %f\n", $v-3.1415; 66 | print "not " unless abs($v-3.1415) < 0.00001; 67 | printf "ok %d\n", ++$Test; 68 | 69 | # 8. Change locale to "English" and convert VARIANT to VT_BSTR 70 | Win32::OLE->Option(LCID => $lcidEnglish); 71 | $v->ChangeType(VT_BSTR); 72 | printf "# VT_BSTR Value in lcid=$lcidEnglish is \"%s\"\n", $v->As(VT_BSTR); 73 | print "not " unless $v->Type == VT_BSTR && "$v" eq "3.1415"; 74 | printf "ok %d\n", ++$Test; 75 | 76 | # 9. Try an invalid conversion and test LastError() method 77 | Win32::OLE->Option(Warn => 0); 78 | Win32::OLE->LastError(0); 79 | my $Before = Win32::OLE->LastError; 80 | $v = Variant(VT_BSTR, "Five"); 81 | $v->ChangeType(VT_I4); 82 | printf "# Before: $Before After: %x\n", Win32::OLE->LastError; 83 | print "not " unless $Before == 0 && Win32::OLE->LastError != 0; 84 | printf "ok %d\n", ++$Test; 85 | Win32::OLE->Option(Warn => 1); 86 | 87 | # 10. Backward compatibility: does Win32::OLE::Variant->LastError() still work? 88 | printf "# Win32::OLE::Variant->LastError: %x\n", Win32::OLE::Variant->LastError; 89 | print "not " unless Win32::OLE->LastError == Win32::OLE::Variant->LastError; 90 | printf "ok %d\n", ++$Test; 91 | 92 | # 11. Special case: VT_UI1 with string argument implies VT_ARRAY 93 | $v = Variant(VT_UI1, "Some string"); 94 | printf "# Type=%x String=\"%s\"\n", $v->Type, $v->Value; 95 | print "not " unless $v->Type == (VT_UI1|VT_ARRAY) && $v->Value eq "Some string"; 96 | printf "ok %d\n", ++$Test; 97 | 98 | # 12. A numeric initializer should create a normal VT_UI1 variant 99 | $v = Variant(VT_UI1, ord('A')); 100 | printf "# Type=%x Value='%c'\n", $v->Type, $v->Value; 101 | print "not " unless $v->Type == VT_UI1 && $v->Value == ord('A'); 102 | printf "ok %d\n", ++$Test; 103 | 104 | # 13. Test assignment to specific type: float to I2 105 | $v = Variant(VT_I2, 42); 106 | printf "# Value (42) is %g\n", $v->Value; 107 | $v->Put(3.1415); 108 | printf "# Value (3.1415) is %g\n", $v->Value; 109 | print "not " unless $v->Value == 3; 110 | printf "ok %d\n", ++$Test; 111 | 112 | # 14. Test assignment to specific type: large integer to I2 113 | $v->Put(70_000); 114 | printf "# Value (70_000) is %g\n", $v->Value; 115 | print "not " unless $v->Value == 70_000-2**16; 116 | printf "ok %d\n", ++$Test; 117 | 118 | # 15. Test VT_BYREF using an alias pointing to the same VARIANT 119 | my $t = Variant(VT_I4|VT_BYREF, 42); 120 | $v = $t->Value; 121 | printf "# Ref=%s Value=%s\n", ref($v), $v; 122 | $v = $t->_Clone; # NB: Undocumented and unsupported function for testing only! 123 | printf "# Ref=%s Value=%s\n", ref($v), $v; 124 | $t->Put(13); 125 | printf "# Ref=%s Value=%s\n", ref($v), $v; 126 | print "not " unless $v->Value == 13; 127 | printf "ok %d\n", ++$Test; 128 | undef $v; 129 | undef $t; 130 | 131 | # 16. Copy() method should make a *real* copy 132 | $t = Variant(VT_BYREF|VT_ARRAY|VT_I4, 2); 133 | $t->Put(0,2); 134 | $t->Put(1,3); 135 | $v = $t->Copy; 136 | $t->Put(1,4); 137 | printf "# v(%x)=%d t(%x)=%d\n", $v->Type, $v->Get(1), $t->Type, $t->Get(1); 138 | print "not " unless $v->Type == (VT_ARRAY | VT_I4) && 139 | $v->Get(1) == 3 && $t->Get(1) == 4; 140 | printf "ok %d\n", ++$Test; 141 | 142 | # 17. Test various VT_UI1 manipulations 143 | $v = Variant(VT_ARRAY|VT_UI1|VT_BYREF, 8); 144 | $v->Put("1234567890"); 145 | $v->Put(1,''); 146 | $v->Put(3,'ABC'); 147 | $v->Put(6,32); 148 | printf "# String=\"%s\"\n", $v->Value; 149 | print "not " unless $v->Value eq "1\0003A56 8"; 150 | printf "ok %d\n", ++$Test; 151 | 152 | # 18. Assignment by string should be '\0' padded 153 | $v->Put("ABCD"); 154 | printf "# String=\"%s\"\n", $v->Value; 155 | print "not " unless $v->Value eq "ABCD"."\0" x 4; 156 | printf "ok %d\n", ++$Test; 157 | 158 | # 19. Test non-0 lower bound and Get() method 159 | $v = Variant(VT_ARRAY|VT_UI1, [10,13]); 160 | $v->Put("123"); 161 | printf "# String=\"%s\", Get(11)=%d\n", $v->Get, $v->Get(11); 162 | print "not " unless $v->Get eq "123\0" && $v->Get(11) == ord('2'); 163 | printf "ok %d\n", ++$Test; 164 | 165 | # 20. Test multidimensional array 166 | $v = Variant(VT_ARRAY|VT_BYREF|VT_VARIANT, 3, [1,2]); 167 | my @dim = $v->Dim; 168 | printf "# Dim: %s\n", join(', ', map {'['.join(',', @$_).']'} @dim); 169 | print "not " unless $dim[0][0] == 0 && $dim[0][1] == 2 && 170 | $dim[1][0] == 1 && $dim[1][1] == 2; 171 | printf "ok %d\n", ++$Test; 172 | 173 | # 21. Assignment to VT_VARIANT array 174 | $v->Put(0, 1, "Perl"); 175 | $v->Put(1, 2, 3.1415); 176 | printf "# String=\"%s\" Number=%s\n", $v->Get(0,1), $v->Get(1,2); 177 | print "not " unless $v->Get(0,1) eq 'Perl' && $v->Get(1,2) == 3.1415; 178 | printf "ok %d\n", ++$Test; 179 | 180 | # 22. Get() applied to VT_VARIANT array should return a value, *not* an object 181 | printf "# ref=\"%s\"\n", ref($v->Get(0,1)); 182 | print "not " if ref($v->Get(0,1)); 183 | printf "ok %d\n", ++$Test; 184 | 185 | # 23. Copy() can be used to retrieve an element as a Variant object 186 | $t = $v->Copy(0,1); 187 | printf "# Type=%x Value=\"%s\"\n", $t->Type, $t->Value; 188 | print "not " unless $t->Type == VT_BSTR and $t->Value eq 'Perl'; 189 | printf "ok %d\n", ++$Test; 190 | 191 | # 24. Put() returns reference to $self 192 | $v->Put(0,1,'One')->Put(1,1,2); 193 | printf "# One=\"%s\" Two=%s\n", $v->Get(0,1), $v->Get(1,1); 194 | print "not " unless $v->Get(0,1) eq 'One' && $v->Get(1,1) == 2; 195 | printf "ok %d\n", ++$Test; 196 | 197 | # 25. Put(ARRAYREF) sets SAFEARRAY 198 | #$v = Variant(VT_ARRAY|VT_I4, 2, 2)->Put([[11, 12], [21, 22]]); 199 | $v = Variant(VT_ARRAY|VT_I4, 2, 2)->Put([[11, 12], [21, 22]]); 200 | printf "# Dim: %s\n", join(', ', map {'['.join(',', @$_).']'} $v->Dim); 201 | printf "# (0,0)=%d (0,1)=%d (1,0)=%d (1,1)=%d\n", $v->Get(0,0), $v->Get(0,1), 202 | $v->Get(1,0), $v->Get(1,1); 203 | print "not " unless $v->Get(0,0) == 11 && $v->Get(1,1) == 22; 204 | printf "ok %d\n", ++$Test; 205 | 206 | # 26. Float -> CURRENCY conversion in non-english locale 207 | Win32::OLE->Option(LCID => $lcidGerman); 208 | my $cy = Variant(VT_CY, 1.2345); 209 | printf "# VT_CY String is '%s' Number is '%f'\n", $cy, $cy; 210 | print "not " unless $cy == 1.2345; 211 | printf "ok %d\n", ++$Test; 212 | 213 | # 27. GetDateFormat with formating options 214 | Win32::OLE->Option(LCID => $lcidEnglish); 215 | $v = Variant(VT_DATE, "1 may 1999 17:00"); 216 | my $str = $v->Date(DATE_LONGDATE); 217 | print "# LONGDATE is '$str'\n"; 218 | print "not " unless $str =~ /^Saturday, May 0?1, 1999$/; 219 | printf "ok %d\n", ++$Test; 220 | 221 | # 28. GetDateFormat with formating string 222 | $str = $v->Date('dd-MMM-yyyy'); 223 | print "# dd-MMM-yyyy is '$str'\n"; 224 | print "not " unless $str eq '01-May-1999'; 225 | printf "ok %d\n", ++$Test; 226 | 227 | # 29. GetDateFormat with locale id 228 | $str = $v->Date(DATE_LONGDATE, $lcidGerman); 229 | print "# German LONGDATE is '$str'\n"; 230 | print "not " unless $str eq 'Samstag, 1. Mai 1999'; 231 | printf "ok %d\n", ++$Test; 232 | 233 | # 30. Currency variant with maximum negative value 234 | my $val = "-922337203685477.5808"; 235 | $v = Variant(VT_CY, $val); 236 | print "# Big currency value as BSTR: $v\n"; 237 | print "not " unless $v eq $val; 238 | printf "ok %d\n", ++$Test; 239 | 240 | # 31. R8 doesn't have enough precission to accurately hold the CY value 241 | printf "# Big currency value as R8: %.4f\n", $v; 242 | print "not " if $v->As(VT_R8) eq $val; 243 | printf "ok %d\n", ++$Test; 244 | 245 | # 32. Format as currency with 4 decimal places 246 | $str = $v->Currency({NumDigits => 4, 247 | Grouping => 3, 248 | NegativeOrder => 0, 249 | DecimalSep => '.', 250 | ThousandSep => ',', 251 | CurrencySymbol => '$', 252 | }); 253 | printf "# Big currency value as CY: $str\n"; 254 | print "not " unless $str eq '($922,337,203,685,477.5808)'; 255 | printf "ok %d\n", ++$Test; 256 | 257 | # 33. Use both a CURRENCYFMT hash *and* a locale id 258 | $str = $v->Currency({CurrencySymbol => "Tuits"}, $lcidGerman); 259 | printf "# Big currency value as tuits: $str\n"; 260 | print "not " unless $str eq '-922.337.203.685.477,58 Tuits'; 261 | printf "ok %d\n", ++$Test; 262 | 263 | # 34. Test VARIANT->Put(ARRAYREF) 264 | $v = Variant(VT_ARRAY|VT_I4, 2, 2); 265 | $v->Put([[1,2],[3,4]]); 266 | $v = Variant(VT_BYREF|VT_VARIANT, $v); 267 | printf "# v(0,0)=%d v(1,1)=%d\n", $v->Get(0,0), $v->Get(1,1); 268 | print "not " unless $v->Get(0,0) == 1 && $v->Get(1,1) == 4; 269 | printf "ok %d\n", ++$Test; 270 | 271 | # 35. Test SAFEARRAY of BSTRs 272 | $v = Variant(VT_ARRAY|VT_BSTR, 2); 273 | $v->Put(0,'Hello')->Put(1,'World'); 274 | printf "# v(0)=%s\n", $v->Get(0); 275 | print "not " unless $v->Get(0) eq 'Hello'; 276 | printf "ok %d\n", ++$Test; 277 | 278 | # 36. Test NULL BSTR value (vbNullString) 279 | $v = nullstring(); 280 | printf "# Type=%s NullString=%s\n", $v->Type, $v->IsNullString ? "yes" : "no"; 281 | print "not " unless $v->Type == VT_BSTR && $v->Value eq "" && $v->IsNullString; 282 | printf "ok %d\n", ++$Test; 283 | 284 | # 37. Test "" BSTR value 285 | $v = Variant(VT_BSTR, ""); 286 | printf "# Type=%s NullString=%s\n", $v->Type, $v->IsNullString ? "yes" : "no"; 287 | print "not " unless $v->Type == VT_BSTR && $v->Value eq "" && !$v->IsNullString; 288 | printf "ok %d\n", ++$Test; 289 | 290 | # 38. Test NULL DISPATCH value 291 | $v = nothing(); 292 | printf "# Type=%s Nothing=%s\n", $v->Type, $v->IsNothing ? "yes" : "no"; 293 | print "not " unless $v->Type == VT_DISPATCH && $v->IsNothing; 294 | printf "ok %d\n", ++$Test; 295 | 296 | # 39. Test SAFEARRAY f VARIANTs 297 | #$v = Variant(VT_ARRAY|VT_VARIANT, 2); 298 | #$v->Put(0,Variant(VT_CY, 4.23))->Put(1,Variant(VT_I2, 42)); 299 | # TODO: Get() doesn't return Variant objects here 300 | #printf "# vt(0)=%d v(1)==%d\n", $v->Get(0)->Type, $v->Get(1)->Type; 301 | #print "not " unless $v->Get(0) eq 'Hello'; 302 | -------------------------------------------------------------------------------- /t/3_ole.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # 3 | # Test Win32::OLE.pm module using MS Excel 4 | # 5 | ######################################################################## 6 | # If you rearrange the tests, please renumber: 7 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 3_ole.t 8 | ######################################################################## 9 | 10 | package Excel; 11 | use strict; 12 | use Win32::OLE; 13 | 14 | use strict qw(vars); 15 | use vars qw($AUTOLOAD @ISA $Warn $LastError $CP $LCID $Tie $Variant); 16 | # use BEGIN because the class is already used in BEGIN block later 17 | BEGIN { 18 | @ISA = qw(Win32::OLE); 19 | $CP = Win32::OLE->Option('CP'); 20 | $LCID = Win32::OLE->Option('LCID'); 21 | # This is necessary to get the _NewEnum property access working! 22 | $Tie = "Excel::Tie"; 23 | @Excel::Tie::ISA = qw(Win32::OLE::Tie); 24 | @Excel::Variant::ISA = qw(Win32::OLE::Variant); 25 | } 26 | 27 | sub AUTOLOAD { 28 | my $self = shift; 29 | $AUTOLOAD = "Win32::OLE::" . substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1; 30 | my $retval = $self->$AUTOLOAD(@_); 31 | return $retval if defined($retval) || $AUTOLOAD eq 'DESTROY'; 32 | printf "# $AUTOLOAD returned OLE error 0x%08x\n", $LastError; 33 | $::Fail = $::Test; 34 | return; 35 | } 36 | 37 | 38 | ######################################################################## 39 | 40 | package main; 41 | use strict; 42 | no warnings "utf8"; 43 | 44 | use Cwd; 45 | use FileHandle; 46 | use Sys::Hostname; 47 | 48 | use Win32::OLE qw(CP_ACP CP_OEMCP CP_UTF8 HRESULT in valof with); 49 | use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG :LOCALE); 50 | use Win32::OLE::Variant; 51 | 52 | $Excel::Variant = 1; 53 | $Excel::CP = CP_UTF8; 54 | 55 | use vars qw($Test $Fail); 56 | 57 | $^W = 1; 58 | 59 | STDOUT->autoflush(1); 60 | STDERR->autoflush(1); 61 | 62 | open(ME,$0) or die $!; 63 | my $TestCount = grep(/\+\+\$Test/,); 64 | close(ME); 65 | 66 | sub stringify { 67 | my $arg = shift; 68 | return "" unless defined $arg; 69 | if (ref $arg eq 'ARRAY') { 70 | my $res; 71 | foreach my $elem (@$arg) { 72 | $res .= "," if defined $res; 73 | $res .= stringify($elem); 74 | } 75 | return "[$res]"; 76 | } 77 | return "$arg"; 78 | } 79 | 80 | sub Quit { 81 | $_[0]->Win32::OLE::Quit; 82 | print "not " unless ++$Test == $TestCount; 83 | print "ok $TestCount\n"; 84 | } 85 | 86 | # 1. Create a new Excel automation server 87 | my $Excel; 88 | BEGIN { 89 | $Excel::Warn = 0; 90 | $Excel = Excel->new('Excel.Application', \&Quit); 91 | $Excel::Warn = 2; 92 | unless (defined $Excel) { 93 | my $Msg = Excel->LastError; 94 | chomp $Msg; 95 | $Msg =~ s/\n/\n\# /g; 96 | print "# $Msg\n"; 97 | print "1..0 # skip Excel.Application not installed\n"; 98 | exit 0; 99 | } 100 | } 101 | # We only ever get here if Excel is actually installed 102 | use Win32::OLE::Const ('Microsoft Excel'); 103 | 104 | $Test = 0; 105 | print "1..$TestCount\n"; 106 | my $File = cwd . "\\test.xls"; 107 | if ($^O eq 'cygwin') { 108 | $File =~ s#\\#/#g; 109 | chomp($File = `cygpath -w '$File'`); 110 | } 111 | # Excel 2007 doesn't handle forward slashes anymore... 112 | $File =~ s#/#\\#g; 113 | unlink $File if -f $File; 114 | print "# File is '$File'\n"; 115 | 116 | printf "# Excel is %s\n", $Excel; 117 | my $Type = Win32::OLE->QueryObjectType($Excel); 118 | print "# App object type is $Type\n"; 119 | printf "ok %d\n", ++$Test; 120 | 121 | # 2. Make sure the CreateObject function works too 122 | my $Obj; 123 | my $Value = Win32::OLE::CreateObject('Excel.Application', $Obj); 124 | print "not " unless $Value && UNIVERSAL::isa($Obj, 'Win32::OLE'); 125 | printf "ok %d\n", ++$Test; 126 | $Obj->Quit if defined $Obj; 127 | 128 | # 3. Add a workbook (with default number of sheets) 129 | $Excel->{SheetsInNewWorkbook} = 3; 130 | my $Book = $Excel->Workbooks->Add; 131 | $Type = Win32::OLE->QueryObjectType($Book); 132 | print "# Book object type is $Type\n"; 133 | print "not " unless defined $Book; 134 | printf "ok %d\n", ++$Test; 135 | 136 | # 4. Test if class is inherited by objects created through $Excel 137 | print "not " unless UNIVERSAL::isa($Book,'Excel'); 138 | printf "ok %d\n", ++$Test; 139 | 140 | # 5. Generate OLE error, should be "croaked" by Win32::OLE 141 | eval { local $Excel::Warn = 3; $Book->Xyzzy(223); }; 142 | my $Msg = $@; 143 | chomp $Msg; 144 | $Msg =~ s/\n/\n\# /g; 145 | print "# Died with msg:\n# $Msg\n"; 146 | print "not " unless $@; 147 | printf "ok %d\n", ++$Test; 148 | 149 | # 6. Generate OLE error, should be trapped by Excel subclass 150 | $Fail = -1; 151 | { local $Excel::Warn = 0; $Book->Xyzzy(223); }; 152 | printf "# Excel::LastError returns (num): 0x%08x\n", Excel->LastError(); 153 | $Msg = Excel->LastError(); 154 | $Msg =~ s/\n/\n\# /g; 155 | printf "# Excel::LastError returns (str):\n# $Msg\n"; 156 | Excel->LastError(0); 157 | printf "# Excel::LastError returns (num): 0x%08x\n", Excel->LastError(); 158 | printf "# Excel::LastError returns (str): %s\n", Excel->LastError(); 159 | print "not " if $Fail != $Test; 160 | printf "ok %d\n", ++$Test; 161 | 162 | # 7. Set 'Warn' option to subroutine reference 163 | $Msg = ''; 164 | Excel->Option(Warn => sub {goto Error}); 165 | $Book->Plugh(42); 166 | $Msg = "not "; 167 | Error: 168 | printf "${Msg}ok %d\n", ++$Test; 169 | Excel->Option(Warn => 2); 170 | 171 | # 8. Get an object for 1st worksheet 172 | my $Sheet = $Book->Worksheets(1); 173 | $Type = Win32::OLE->QueryObjectType($Sheet); 174 | print "# Sheet object type is $Type\n"; 175 | print "not " unless defined $Sheet; 176 | printf "ok %d\n", ++$Test; 177 | 178 | # 9. Catch "invalid type" error, test if index is correct 179 | { local $Excel::Warn = 0; $Sheet->Cells(1, $Sheet); }; 180 | $Msg = Excel->LastError(); 181 | $Msg =~ s/\n/\n\# /g; 182 | printf "# Excel::LastError returns (str):\n# $Msg\n"; 183 | print "not " unless $Msg =~ /"Cells" argument 2/; 184 | printf "ok %d\n", ++$Test; 185 | 186 | # 10. Test the "with" function 187 | printf("# Tests %d and %d will fail if no default printer has been installed yet\n", 188 | $Test+1, $Test+2); 189 | with($Sheet->PageSetup, Orientation => xlLandscape, FirstPageNumber => 13); 190 | $Value = $Sheet->PageSetup->FirstPageNumber; 191 | print "# FirstPageNumber is \"$Value\"\n"; 192 | print "not " unless $Value == 13; 193 | printf "ok %d\n", ++$Test; 194 | 195 | # 11. Test constant value: xlLandscape should be "2" 196 | $Value = $Sheet->PageSetup->Orientation; 197 | print "# Orientation is \"$Value\"\n"; 198 | print "not " unless $Value == 2; 199 | printf "ok %d\n", ++$Test; 200 | 201 | # 12. Test Win32::OLE::Const->Load method 202 | my $xl = Win32::OLE::Const->Load('Microsoft Excel'); 203 | printf "# xlLandscape is \"%s\"\n", $xl->{'xlLandscape'}; 204 | print "not " unless $xl->{'xlLandscape'} == 2; 205 | printf "ok %d\n", ++$Test; 206 | 207 | # 13. Call a method with a magical scalar as argument 208 | my $Sheets = $Book->Worksheets; 209 | my $Name = $Book->Worksheets($Sheets->{Count})->{Name}; 210 | print "# Name is \"$Name\"\n"; 211 | print "not " unless $Name; 212 | printf "ok %d\n", ++$Test; 213 | 214 | # 14. Set values of some cells and retrieve a value 215 | $Sheet->{Name} = 'My Sheet #1'; 216 | foreach my $i (1..10) { 217 | $Sheet->Cells($i,$i)->{Value} = $i**2; 218 | } 219 | my $Cell = $Sheet->Cells(5,5); 220 | $Type = Win32::OLE->QueryObjectType($Cell); 221 | printf "# Cells (%s) object type is $Type\n", ref($Cell); 222 | $Value = $Cell->{Value}; 223 | print "# Value is \"$Value\"\n"; 224 | print "not " unless $Cell->{Value} == 25; 225 | printf "ok %d\n", ++$Test; 226 | 227 | # 15. Call OLE method with $1 as argument 228 | 229 | # This test is commented out because Perl doesn't set POK on $1, 230 | # it seems to be only pPOK, which still gets translated to undef. :( 231 | 232 | #Excel->Option(Warn => 0); 233 | #$_ = "The formula is MIN(77,33,55)"; 234 | #print "# Expression is \"$1\"\n" if /is (.*)/; 235 | ##$Value = $Sheet->Evaluate("MIN(77,33,55)") if /is (.*)/; 236 | #$Value = $Sheet->Evaluate($1) if /is (.*)/; 237 | #Excel->Option(Warn => 2); 238 | #$Value = "" unless defined $Value; 239 | #print "# Value is \"$Value\"\n"; 240 | #print "not " unless $Value eq "33"; 241 | 242 | printf "ok %d\n", ++$Test; 243 | 244 | # 16. Test the valof function 245 | my $RefOf = $Cell; 246 | my $ValOf = valof $Cell; 247 | $Cell->{Value} = 27; 248 | print "not " unless $ValOf == 25 && $RefOf->Value == 27; 249 | printf "ok %d\n", ++$Test; 250 | 251 | # 17. Assign and retrieve a very long string 252 | $Cell->{Value} = 'a' x 300; 253 | printf "# Value is %s\n", $Cell->Value; 254 | print "not " unless $Cell->Value eq ('a' x 300); 255 | printf "ok %d\n", ++$Test; 256 | 257 | # 18. Assign a substr() magical lvalue (doesn't get POK bit set) 258 | $Cell->Dispatch([Win32::OLE::DISPATCH_PROPERTYPUT, 'Value'], 259 | my $retval, substr('xyz', 0, 1)); 260 | printf "# Value is %s\n", $Cell->Value; 261 | print "not " unless $Cell->Value eq 'x'; 262 | printf "ok %d\n", ++$Test; 263 | 264 | # 19. Try to roundtrip a VT_CY value and see if it stays a Variant 265 | $Cell->{Value} = Variant(VT_CY, 125); 266 | $Value = $Cell->{Value}; 267 | printf "# Value is %s, ref=%s, type=%d\n", $Value, ref $Value, $Value->Type; 268 | print "not " unless $Cell->Value == 125 && 269 | ref($Value) eq "Excel::Variant" && 270 | $Value->Type == VT_CY; 271 | printf "ok %d\n", ++$Test; 272 | 273 | # 20. Test 'SetProperty' function 274 | $Cell->SetProperty('Value', 4711); 275 | printf "# Value is %s\n", $Cell->Value; 276 | print "not " unless $Cell->Value == 4711; 277 | printf "ok %d\n", ++$Test; 278 | 279 | # 21. The following tests rely on the fact that the font is not yet bold 280 | printf "# Bold: %s\n", $Cell->Style->Font->Bold; 281 | print "not " if $Cell->Style->Font->Bold; 282 | printf "ok %d\n", ++$Test; 283 | 284 | # 22. Assignment by DISPATCH_PROPERTYPUTREF shouldn't work 285 | my $Style = $Book->Styles->Add("MyStyle"); 286 | $Style->Font->{Bold} = 1; 287 | { local $Excel::Warn = 0; $Cell->{Style} = $Style } 288 | my $LastError = Excel->LastError; 289 | printf "# Bold: %s\n", $Cell->Style->Font->Bold; 290 | printf "# Excel->LastError is 0x%x\n", $LastError; 291 | print "not " if $LastError != HRESULT(0x80020003) || $Cell->Style->Font->Bold; 292 | printf "ok %d\n", ++$Test; 293 | 294 | # 23. But DISPATCH_PROPERTYPUT should be ok 295 | $Cell->LetProperty('Style', $Style); 296 | printf "# Bold: %s\n", $Cell->Style->Font->Bold; 297 | print "not " unless $Cell->Style->Font->Bold; 298 | printf "ok %d\n", ++$Test; 299 | 300 | # 24. Set a cell range from an array ref containing an IV, PV and NV 301 | $Sheet->Range("A8:C9")->{Value} = [[undef, 'Camel', "\x{263a}"],[42, 'Perl', 3.1415]]; 302 | $Value = $Sheet->Cells(9,2)->Value . $Sheet->Cells(8,2)->Value; 303 | print "# Value is \"$Value\"\n"; 304 | print "not " unless $Value eq 'PerlCamel'; 305 | printf "ok %d\n", ++$Test; 306 | 307 | # 25. Retrieve float value (esp. interesting in foreign locales) 308 | $Value = $Sheet->Cells(9,3)->{Value}; 309 | print "# Value is \"$Value\"\n"; 310 | print "not " unless $Value == 3.1415; 311 | printf "ok %d\n", ++$Test; 312 | 313 | # 26. Retrieve unicode value. 314 | $Value = $Sheet->Cells(8,3)->{Value}; 315 | print "# Value is \"$Value\"\n"; 316 | print "not " unless $Value eq "\x{263a}"; 317 | printf "ok %d\n", ++$Test; 318 | 319 | # 27. Make sure the length of the unicode string is correct. 320 | $Value = $Sheet->Cells(8,3)->{Value}; 321 | print "# length(Value) is ", length($Value), "\n"; 322 | print "not " unless length($Value) == length("\x{263a}"); 323 | printf "ok %d\n", ++$Test; 324 | 325 | # 28. Use Unicode::String object to assign BSTR value 326 | eval { require Unicode::String }; 327 | ++$Test; 328 | if ($@) { 329 | printf "ok %d # skip Unicode::String module not installed\n", $Test; 330 | } 331 | else { 332 | $Sheet->Cells(1,3)->{Value} = Unicode::String::utf8("\342\230\272"); 333 | $Value = $Sheet->Cells(1,3)->{Value}; 334 | print "# Value is \"$Value\"\n"; 335 | print "not " unless $Value eq "\x{263a}" && length($Value) == 1; 336 | printf "ok %d\n", $Test; 337 | } 338 | 339 | # 29. Retrieve a 0 dimensional range; check array data structure 340 | $Value = $Sheet->Range("B8")->{Value}; 341 | printf "# Values are: \"%s\"\n", stringify($Value); 342 | print "not " if ref $Value; 343 | printf "ok %d\n", ++$Test; 344 | 345 | # 30. Retrieve a 1 dimensional row range; check array data structure 346 | $Value = $Sheet->Range("B8:C8")->{Value}; 347 | printf "# Values are: \"%s\"\n", stringify($Value); 348 | print "not " unless @$Value == 1 && ref $$Value[0]; 349 | printf "ok %d\n", ++$Test; 350 | 351 | # 31. Retrieve a 1 dimensional column range; check array data structure 352 | $Value = $Sheet->Range("B8:B9")->{Value}; 353 | printf "# Values are: \"%s\"\n", stringify($Value); 354 | print "not " unless @$Value == 2 && ref $$Value[0] && ref $$Value[1]; 355 | printf "ok %d\n", ++$Test; 356 | 357 | # 32. Retrieve a 2 dimensional range; check array data structure 358 | $Value = $Sheet->Range("B8:C9")->{Value}; 359 | printf "# Values are: \"%s\"\n", stringify($Value); 360 | print "not " unless @$Value == 2 && ref $$Value[0] && ref $$Value[1]; 361 | printf "ok %d\n", ++$Test; 362 | 363 | # 33. Check contents of 2 dimensional array 364 | $Value = $$Value[0][0] . $$Value[1][0] . $$Value[1][1]; 365 | print "# Value is \"$Value\"\n"; 366 | print "not " unless $Value eq 'CamelPerl3.1415'; 367 | printf "ok %d\n", ++$Test; 368 | 369 | # 34. Set a cell formula and retrieve calculated value 370 | $Sheet->Cells(3,1)->{Formula} = '=PI()'; 371 | $Value = $Sheet->Cells(3,1)->{Value}; 372 | print "# Value is \"$Value\"\n"; 373 | print "not " unless abs($Value-3.141592) < 0.00001; 374 | printf "ok %d\n", ++$Test; 375 | 376 | # 35. Add single worksheet and check that worksheet count is incremented 377 | my $Count = $Sheets->{Count}; 378 | $Book->Worksheets->Add; 379 | $Value = $Sheets->{Count}; 380 | print "# Count is \"$Count\" and Value is \"$Value\"\n"; 381 | print "not " unless $Value == $Count+1; 382 | printf "ok %d\n", ++$Test; 383 | 384 | # 36. Add 2 more sheets, optional arguments are omitted 385 | $Count = $Sheets->{Count}; 386 | $Book->Worksheets->Add(undef,undef,2); 387 | $Value = $Sheets->{Count}; 388 | print "# Count is \"$Count\" and Value is \"$Value\"\n"; 389 | print "not " unless $Value == $Count+2; 390 | printf "ok %d\n", ++$Test; 391 | 392 | # 37. Add 3 more sheets before sheet 2 using a named argument 393 | $Count = $Sheets->{Count}; 394 | $Book->Worksheets(2)->{Name} = 'XYZZY'; 395 | $Sheets->Add($Book->Worksheets(2), {Count => 3}); 396 | $Value = $Sheets->{Count}; 397 | print "# Count is \"$Count\" and Value is \"$Value\"\n"; 398 | print "not " unless $Value == $Count+3; 399 | printf "ok %d\n", ++$Test; 400 | 401 | # 38. Previous sheet 2 should now be sheet 5 402 | $Value = $Book->Worksheets(5)->{Name}; 403 | print "# Value is \"$Value\"\n"; 404 | print "not " unless $Value eq 'XYZZY'; 405 | printf "ok %d\n", ++$Test; 406 | 407 | # 39. Add 2 more sheets at the end using 2 named arguments 408 | $Count = $Sheets->{Count}; 409 | # Following line doesn't work with Excel 7 (Seems like an Excel bug?) 410 | # $Sheets->Add({Count => 2, After => $Book->Worksheets($Sheets->{Count})}); 411 | $Sheets->Add({Count => 2, After => $Book->Worksheets($Sheets->{Count}-1)}); 412 | print "not " unless $Sheets->{Count} == $Count+2; 413 | printf "ok %d\n", ++$Test; 414 | 415 | # 40. Number of objects in an enumeration must match its "Count" property 416 | my @Sheets = in $Sheets; 417 | printf "# \$Sheets->{Count} is %d\n", $Sheets->{Count}; 418 | printf "# scalar(\@Sheets) is %d\n", scalar(@Sheets); 419 | foreach my $Sheet (@Sheets) { 420 | printf "# Sheet->{Name} is \"%s\"\n", $Sheet->{Name}; 421 | } 422 | print "not " unless $Sheets->{Count} == @Sheets; 423 | printf "ok %d\n", ++$Test; 424 | undef @Sheets; 425 | 426 | # 41. Enumerate all application properties using the C function 427 | my @Properties = keys %$Excel; 428 | printf "# Number of Excel application properties: %d\n", scalar(@Properties); 429 | $Value = grep /^(Parent|Xyzzy|Name)$/, @Properties; 430 | print "# Value is \"$Value\"\n"; 431 | print "not " unless $Value == 2; 432 | printf "ok %d\n", ++$Test; 433 | undef @Properties; 434 | 435 | # 42. Translate character from ANSI -> OEM 436 | ++$Test; 437 | my $oemcp = GetLocaleInfo(GetSystemDefaultLCID(), LOCALE_IDEFAULTCODEPAGE); 438 | if ($oemcp == 437 || $oemcp == 850) { 439 | my ($Version) = $Excel->{Version} =~ /([0-9.]+)/; 440 | print "# Excel version is $Version\n"; 441 | 442 | my $LCID = MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL)); 443 | $LCID = MAKELCID(MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL)) if $Version >= 8; 444 | $Excel::LCID = $LCID; 445 | 446 | $Cell = $Book->Worksheets('My Sheet #1')->Cells(1,5); 447 | $Cell->{Formula} = '=CHAR(163)'; 448 | $Excel::CP = CP_ACP; 449 | my $ANSI = valof $Cell; 450 | $Excel::CP = CP_OEMCP; 451 | my $OEM = valof $Cell; 452 | print "# ANSI(cp1252) -> OEM(cp437/cp850): 163 -> 156\n"; 453 | printf "# ANSI is \"$ANSI\" (%d) and OEM is \"$OEM\" (%d)\n", ord($ANSI), ord($OEM); 454 | print "not " unless ord($ANSI) == 163 && ord($OEM) == 156; 455 | printf "ok %d\n", $Test; 456 | } 457 | else { 458 | printf "ok %d # skip OEM codepage $oemcp is neither 437 nor 850\n", $Test; 459 | } 460 | 461 | # 43. Save workbook to file 462 | print "not " unless $Book->SaveAs($File); 463 | printf "ok %d\n", ++$Test; 464 | 465 | # 44. Check if output file exists. 466 | print "not " unless -f $File; 467 | printf "ok %d\n", ++$Test; 468 | 469 | # 45. Access the same file object through a moniker. 470 | $Obj = Win32::OLE->GetObject($File); 471 | for ($Count=0 ; $Count < 5 ; ++$Count) { 472 | my $Type = Win32::OLE->QueryObjectType($Obj); 473 | print "# Object type is \"$Type\"\n"; 474 | last if $Type =~ /Workbook/; 475 | $Obj = $Obj->{Parent}; 476 | } 477 | $Value = 2.7172; 478 | eval { $Value = $Obj->Worksheets('My Sheet #1')->Range('A3')->{Value}; }; 479 | print "# Value is \"$Value\"\n"; 480 | print "not " unless abs($Value-3.141592) < 0.00001; 481 | printf "ok %d\n", ++$Test; 482 | 483 | 484 | # 46. Get return value as Win32::OLE::Variant object 485 | $Cell = $Obj->Worksheets('My Sheet #1')->Range('B9'); 486 | my $Variant = Win32::OLE::Variant->new(VT_EMPTY); 487 | $Cell->Dispatch('Value', $Variant); 488 | printf "# Variant is (%s,%s)\n", $Variant->Type, $Variant->Value; 489 | print "not " unless $Variant->Type == VT_BSTR && $Variant->Value eq 'Perl'; 490 | printf "ok %d\n", ++$Test; 491 | 492 | # 47. Use clsid string to start OLE server 493 | undef $Value; 494 | eval { 495 | require Win32::Registry; 496 | Win32::Registry->import(qw(RegOpenKeyEx KEY_READ)); 497 | use vars qw($HKEY_CLASSES_ROOT); 498 | # Use Win32::Registry internals to open registry key in readonly mode 499 | RegOpenKeyEx($HKEY_CLASSES_ROOT->{handle}, 'Excel.Application\CLSID', 500 | undef, KEY_READ(), my $HKey); 501 | $HKey = Win32::Registry::_new($HKey); 502 | $HKey->QueryValue('', my $CLSID); 503 | $HKey->Close; 504 | print "# Excel CLSID is $CLSID\n"; 505 | $Obj = Win32::OLE->new($CLSID); 506 | $Value = (Win32::OLE->QueryObjectType($Obj))[0]; 507 | $Obj->Quit if $Value eq 'Excel'; 508 | }; 509 | ++$Test; 510 | if ($@) { 511 | printf "ok %d # skip Registry problem $@\n", $Test; 512 | } 513 | else { 514 | print "# Object application is $Value\n"; 515 | print "not " unless $Value eq 'Excel'; 516 | printf "ok %d\n", $Test; 517 | } 518 | 519 | # 48. Use DCOM syntax to start server (on local machine though) 520 | # This might fail (on Win95/NT3.5 if DCOM support is not installed. 521 | $Obj = Win32::OLE->new([hostname, 'Excel.Application'], 'Quit'); 522 | $Value = (Win32::OLE->QueryObjectType($Obj))[0]; 523 | print "# Object application is $Value\n"; 524 | print "not " unless $Value eq 'Excel'; 525 | printf "ok %d\n", ++$Test; 526 | 527 | # 49. Find $Excel object via EnumAllObjects() 528 | my $Found = 0; 529 | $Count = Win32::OLE->EnumAllObjects(sub { 530 | my $Object = shift; 531 | my $Class = Win32::OLE->QueryObjectType($Object); 532 | $Class = "" unless defined $Class; 533 | printf "# Object=%s Class=%s\n", $Object, $Class; 534 | $Found = 1 if $Object == $Excel; 535 | }); 536 | print "# Count=$Count Found=$Found\n"; 537 | print "not " unless $Found; 538 | printf "ok %d\n", ++$Test; 539 | 540 | # 50. _NewEnum should normally be non-browseable 541 | my $Exists = grep /^_NewEnum$/, keys %{$Excel->Worksheets}; 542 | print "# Exists=$Exists\n"; 543 | print "not " if $Exists; 544 | printf "ok %d\n", ++$Test; 545 | 546 | # 51. make _NewEnum visible 547 | Excel->Option(_NewEnum => 1); 548 | $Exists = grep /^_NewEnum$/, keys %{$Excel->Worksheets}; 549 | print "# Exists=$Exists\n"; 550 | print "not " unless $Exists; 551 | printf "ok %d\n", ++$Test; 552 | 553 | # 52. _NewEnum available as a method 554 | @Sheets = @{$Excel->Worksheets->_NewEnum}; 555 | print "# $_->{Name}\n" foreach @Sheets; 556 | print "not " unless @Sheets == 11 && grep $_->Name eq "My Sheet #1", @Sheets; 557 | printf "ok %d\n", ++$Test; 558 | 559 | # 53. _NewEnum available as a property 560 | @Sheets = @{$Excel->Worksheets->{_NewEnum}}; 561 | print "not " unless @Sheets == 11 && grep $_->Name eq "My Sheet #1", @Sheets; 562 | printf "ok %d\n", ++$Test; 563 | 564 | # 54. Win32::OLE proxies are non-unique by default 565 | my $Application = $Excel->Application; 566 | my $Parent = $Excel->Parent; 567 | printf "# Application=%d Parent=%d\n", $Application, $Parent; 568 | print "not " if $Application == $Parent; 569 | printf "ok %d\n", ++$Test; 570 | 571 | # 55. Parent and Application property should now return the same object 572 | Excel->Option(_Unique => 1); 573 | $Application = $Excel->Application; 574 | $Parent = $Excel->Parent; 575 | printf "# Application=%d Parent=%d\n", $Application, $Parent; 576 | print "not " unless $Application == $Parent; 577 | printf "ok %d\n", ++$Test; 578 | 579 | # 56. Determine Dispatch ID of "Parent" 580 | my $dispid = $Excel->GetIDsOfNames("Parent"); 581 | print "# DispID=$dispid\n"; 582 | print "not " unless $dispid == 150; 583 | printf "ok %d\n", ++$Test; 584 | 585 | # 57. Dispatch using numeric ID instead of method/property name 586 | $Parent = $Excel->Invoke($dispid); 587 | printf "# Application=%d Parent=%d\n", $Application, $Parent; 588 | print "not " unless $Application == $Parent; 589 | printf "ok %d\n", ++$Test; 590 | 591 | # 58. Terminate server instance ("ok $Test\n" printed by Excel destructor) 592 | exit; 593 | -------------------------------------------------------------------------------- /t/4_compat.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # 3 | # Test of the OLE.pm compatibility module using MS Excel 4 | # 5 | ######################################################################## 6 | # If you rearrange the tests, please renumber: 7 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 4_compat.t 8 | ######################################################################## 9 | 10 | use strict; 11 | use FileHandle; 12 | use OLE; 13 | 14 | $^W = 1; 15 | STDOUT->autoflush(1); 16 | STDERR->autoflush(1); 17 | 18 | open(ME,$0) or die $!; 19 | my $TestCount = grep(/\+\+\$Test/,); 20 | close(ME); 21 | 22 | my $Test = 0; 23 | 24 | # 1. Create Excel object using CreateObject syntax 25 | my $xl = CreateObject OLE "Excel.Application"; 26 | unless (defined $xl) { 27 | print "1..0 # skip Excel.Application not installed\n"; 28 | exit 0; 29 | } 30 | print "1..$TestCount\n"; 31 | 32 | print "# Excel is \"$xl\"\n"; 33 | my $bk = $xl->Workbooks->Add; 34 | # This also checks if overloading was turned off again 35 | # Otherwise value of $bk is "" which is FALSE 36 | print "# Value is \"$bk\"\n"; 37 | print "not " unless $bk; 38 | printf "ok %d\n", ++$Test; 39 | 40 | # 2. "Unnamed" Item method 41 | my $name = $xl->Worksheets(1)->{Name}; 42 | my $sheet = $xl->Worksheets->{$name}; 43 | print "not " unless UNIVERSAL::isa($sheet, 'Win32::OLE'); 44 | printf "ok %d\n", ++$Test; 45 | 46 | # 3. Enumerate collection using C syntax 47 | my @sheets = keys %{$xl->Worksheets}; 48 | print "not " unless UNIVERSAL::isa($sheets[0], 'Win32::OLE'); 49 | printf "ok %d\n", ++$Test; 50 | 51 | # 4. Create VARIANT 52 | my $ovR8 = new OLE::Variant(OLE::VT_R8, '3'); 53 | $xl->Range("a2")->{Value} = $ovR8; 54 | print "not " unless $xl->Range("a2")->{Value} == 3; 55 | printf "ok %d\n", ++$Test; 56 | 57 | # 5. Quit Excel 58 | $bk->{Saved} = 1; 59 | $xl->Quit; 60 | undef $xl; 61 | printf "ok %d\n", ++$Test; 62 | -------------------------------------------------------------------------------- /t/5_unicode.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # If you rearrange the tests, please renumber: 3 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 5_unicode.t 4 | ######################################################################## 5 | # 6 | # !!! These tests will not run unless "Unicode::String" is installed !!! 7 | # 8 | ######################################################################## 9 | 10 | use strict; 11 | no warnings "utf8"; 12 | 13 | use FileHandle; 14 | use Win32::OLE::Variant; 15 | 16 | $^W = 1; 17 | STDOUT->autoflush(1); 18 | STDERR->autoflush(1); 19 | Win32::OLE->Option(CP => Win32::OLE::CP_UTF8); 20 | 21 | open(ME,$0) or die $!; 22 | my $TestCount = grep(/\+\+\$Test/,); 23 | close(ME); 24 | 25 | eval { require Unicode::String }; 26 | if ($@) { 27 | print "1..0 # skip Unicode::String module not installed\n"; 28 | exit 0; 29 | } 30 | 31 | my $Test = 0; 32 | print "1..$TestCount\n"; 33 | 34 | # 1. Create a simple BSTR and convert to Unicode and back 35 | my $v = Variant(VT_BSTR, '3,1415'); 36 | printf "# Type=%s Value=%s\n", $v->Type, $v->Value; 37 | my $u = $v->Unicode; 38 | print "not " unless $u->utf8 eq '3,1415'; 39 | printf "ok %d\n", ++$Test; 40 | 41 | # 2. Check if we can convert a _big_ unicode character 42 | $v = Variant(VT_BSTR, "\x{263a}"); 43 | $u = $v->Unicode; 44 | printf "# v='%s' u='%s'\n", $v->Value, $u->utf8; 45 | print "not " unless "\342\230\272" eq $u->utf8; 46 | printf "ok %d\n", ++$Test; 47 | 48 | # 3. Convert Unicode::String back to Variant 49 | $v = Variant(VT_BSTR, $u); 50 | printf "# v='%s' u='%s'\n", $v->Value, $u->utf8; 51 | print "not " unless "\x{263a}" eq $v->Value; 52 | printf "ok %d\n", ++$Test; 53 | -------------------------------------------------------------------------------- /t/6_event.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # 3 | # Test Win32::OLE Event support using MS Excel 4 | # 5 | ######################################################################## 6 | # If you rearrange the tests, please renumber: 7 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 6_event.t 8 | ######################################################################## 9 | 10 | use strict; 11 | use Win32::OLE qw(EVENTS); 12 | 13 | use Cwd; 14 | 15 | $|=$^W = 1; 16 | 17 | open(ME,$0) or die $!; 18 | my $TestCount = grep(/\+\+\$Test/,); 19 | close(ME); 20 | 21 | # 1. Create a new Excel automation server 22 | my ($Excel,$File); 23 | BEGIN { 24 | $File = cwd . "\\test.xls"; 25 | $File =~ s#\\#/#g, chomp($File = `cygpath -w '$File'`) if $^O eq 'cygwin'; 26 | chomp($File = `cygpath -w '$File'`) if $^O eq 'cygwin'; 27 | unless (-f $File) { 28 | print "1..0 # skip $File doesn't exist! Please run test 3_ole.t first\n"; 29 | exit 0; 30 | } 31 | Win32::OLE->Option(Warn => 0); 32 | $Excel = Win32::OLE->new('Excel.Application', 'Quit'); 33 | Win32::OLE->Option(Warn => 2); 34 | unless (defined $Excel) { 35 | my $Msg = Win32::OLE->LastError; 36 | chomp $Msg; 37 | $Msg =~ s/\n/\n\# /g; 38 | print "# $Msg\n"; 39 | print "1..0 # skip Excel.Application not installed\n"; 40 | exit 0; 41 | } 42 | } 43 | 44 | # We only ever get here if Excel is actually installed 45 | my $Test = 0; 46 | print "1..$TestCount\n"; 47 | printf "# Excel is %s\n", $Excel; 48 | printf "ok %d\n", ++$Test; 49 | 50 | # 2. Connect generic Event handler function to Application object 51 | my %Events; 52 | sub Event { 53 | my ($Obj,$Event) = @_; 54 | ++$Events{$Event}; 55 | print "# Event triggered: '$Event'\n"; 56 | } 57 | Win32::OLE->WithEvents($Excel, \&Event, 'AppEvents'); 58 | my $Book = $Excel->Workbooks->Open($File); 59 | print "not " unless $Events{WorkbookOpen}; 60 | printf "ok %d\n", ++$Test; 61 | 62 | # 3. Connect Event package to Workbook object 63 | 64 | # disconnect Application Events 65 | Win32::OLE->WithEvents($Excel); 66 | undef %Events; 67 | 68 | my $MayClose; 69 | package Workbook; 70 | sub BeforeClose { 71 | my ($self,$Cancel) = @_; 72 | $Cancel->Put(1) unless $MayClose; 73 | print "# BeforeClose: Cancel is now ", $Cancel->Value, "\n"; 74 | } 75 | 76 | package main; 77 | Win32::OLE->WithEvents($Book, 'Workbook', 'WorkbookEvents'); 78 | printf "# Workbookcount: %d\n", $Excel->Workbooks->Count; 79 | # try to close workbook. This should *not* succeed! 80 | $Book->Close; 81 | my $Count = $Excel->Workbooks->Count; 82 | printf "# Workbookcount: $Count\n"; 83 | print "not " unless $Count == 1; 84 | printf "ok %d\n", ++$Test; 85 | 86 | # 4. There shouldn't have been any Application events 87 | print "not " if scalar keys %Events; 88 | printf "ok %d\n", ++$Test; 89 | 90 | # 5. This time BeforeClose shall *not* cancel the action 91 | $MayClose = 1; 92 | $Book->Close; 93 | $Count = $Excel->Workbooks->Count; 94 | printf "# Workbookcount: $Count\n"; 95 | print "not " unless $Count == 0; 96 | printf "ok %d\n", ++$Test; 97 | 98 | # 6. Test the Forwarder object 99 | my $forward = Win32::OLE->Forward(sub {$MayClose = shift}); 100 | $forward->Invoke(undef, 42); 101 | print "# MayClose is $MayClose\n"; 102 | print "not " unless $MayClose == 42; 103 | printf "ok %d\n", ++$Test; 104 | -------------------------------------------------------------------------------- /t/7_overload.t: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # 3 | # Test overloaded conversions of Win32::OLE objects using MS Excel 4 | # 5 | ######################################################################## 6 | # If you rearrange the tests, please renumber: 7 | # perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 7_overload.t 8 | ######################################################################## 9 | 10 | use strict; 11 | use Cwd; 12 | use Sys::Hostname; 13 | 14 | use Win32::OLE qw(OVERLOAD); 15 | 16 | $|=$^W = 1; 17 | 18 | open(ME,$0) or die $!; 19 | my $TestCount = grep(/\+\+\$Test/,); 20 | close(ME); 21 | 22 | # 1. Create a new Excel automation server 23 | my ($Excel,$File); 24 | BEGIN { 25 | $File = cwd . "\\test.xls"; 26 | $File =~ s#\\#/#g, chomp($File = `cygpath -w '$File'`) if $^O eq 'cygwin'; 27 | unless (-f $File) { 28 | print "1..0 # skip $File doesn't exist! Please run test 3_ole.t first\n"; 29 | exit 0; 30 | } 31 | Win32::OLE->Option(Warn => 0); 32 | $Excel = Win32::OLE->new('Excel.Application', 'Quit'); 33 | Win32::OLE->Option(Warn => 2); 34 | unless (defined $Excel) { 35 | my $Msg = Win32::OLE->LastError; 36 | chomp $Msg; 37 | $Msg =~ s/\n/\n\# /g; 38 | print "# $Msg\n"; 39 | print "1..0 # skip Excel.Application not installed\n"; 40 | exit 0; 41 | } 42 | } 43 | 44 | # We only ever get here if Excel is actually installed 45 | my $Test = 0; 46 | print "1..$TestCount\n"; 47 | printf "# Excel is %s\n", $Excel; 48 | print "not " unless $Excel eq "Microsoft Excel"; 49 | printf "ok %d\n", ++$Test; 50 | 51 | # 2. Retrieve a value 52 | my $Book = $Excel->Workbooks->Open($File); 53 | my $Sheet = $Book->Worksheets('My Sheet #1'); 54 | my $Cell = $Sheet->Cells(5,5); 55 | my $Value = $Cell->{Value}; 56 | printf "# Value is %f\n", $Cell->{Value}; 57 | print "not " unless $Cell->{Value} == 4711; 58 | printf "ok %d\n", ++$Test; 59 | 60 | # 3. Check if overloading conversion to number/string works 61 | printf "# Value is %f\n", $Cell; 62 | print "not " unless $Cell == 4711; 63 | printf "ok %d\n", ++$Test; 64 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | eval 'use Test::Pod 1.00'; 4 | plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@; 5 | 6 | all_pod_files_ok(); 7 | --------------------------------------------------------------------------------