PageRenderTime 27ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/site/lib/OLE.pm

#
Perl | 177 lines | 116 code | 33 blank | 28 comment | 3 complexity | 89633eb08c828fdc2fe2974ec292fabc MD5 | raw file
Possible License(s): GPL-2.0, MPL-2.0-no-copyleft-exception, CPL-1.0, CC-BY-SA-3.0, BSD-3-Clause, ISC, AGPL-3.0, LGPL-2.1, Apache-2.0
  1. # Compatibility layer for applications using the old toplevel OLE.pm.
  2. # New code should use Win32::OLE
  3. # This file is based on ../lib/OLE.pm from ActiveState build 315.
  4. # Compatibility notes:
  5. # - "GetObject" -> "GetActiveObject"
  6. # - "keys %$collection" -> "Win32::OLE::Enum->All($collection)"
  7. # or "in $Collection"
  8. # - "unnamed" default method retries
  9. ########################################################################
  10. package Win32;
  11. ########################################################################
  12. sub OLELastError {return OLE->LastError()}
  13. ########################################################################
  14. package OLE::Variant;
  15. ########################################################################
  16. use Win32::OLE qw(CP_ACP);
  17. use Win32::OLE::Variant;
  18. use strict;
  19. use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $_NewEnum $_Unique);
  20. @ISA = qw(Win32::OLE::Variant);
  21. $Warn = 0;
  22. $LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT
  23. $CP = CP_ACP;
  24. $_NewEnum = 0;
  25. $_Unique = 0;
  26. sub new {
  27. my $self = shift;
  28. my $variant = $self->SUPER::new(@_);
  29. $OLE::LastError = $Win32::OLE->LastError unless defined $variant;
  30. return $variant;
  31. }
  32. ########################################################################
  33. package OLE::Tie;
  34. ########################################################################
  35. use strict;
  36. use vars qw(@ISA);
  37. @ISA = qw(Win32::OLE::Tie);
  38. # !!! It is VERY important that Win32::OLE::Tie::DESTROY gets called. !!!
  39. # If you subclass DESTROY, don't forget to call $self->SUPER::DESTROY.
  40. # Otherwise the OLE interfaces will not be released until process termination!
  41. # Retry default method if property doesn't exist
  42. sub FETCH {
  43. my ($self,$key) = @_;
  44. return $self->SUPER::Fetch($key, 1);
  45. }
  46. sub STORE {
  47. my ($self,$key,$value) = @_;
  48. $self->SUPER::Store($key, $value, 1);
  49. }
  50. # Enumerate collection members, not object properties
  51. *FIRSTKEY = *Win32::OLE::Tie::FIRSTENUM;
  52. *NEXTKEY = *Win32::OLE::Tie::NEXTENUM;
  53. ########################################################################
  54. package OLE;
  55. ########################################################################
  56. use Win32::OLE qw(CP_ACP);
  57. # Use OleInitialize() instead of CoInitializeEx:
  58. Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE);
  59. use strict;
  60. # Disable overload; unfortunately "no overload" doesn't do it :-(
  61. # Overloading is no longer enabled by default in Win32::OLE
  62. #use overload '""' => sub {overload::StrVal($_[0])},
  63. # '0+' => sub {overload::StrVal($_[0])};
  64. use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $Tie);
  65. @ISA = qw(Win32::OLE);
  66. $Warn = 0;
  67. $LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT
  68. $CP = CP_ACP;
  69. $Tie = 'OLE::Tie';
  70. sub new {
  71. my $class = shift;
  72. $class = shift if $class eq 'OLE';
  73. return OLE->SUPER::new($class);
  74. }
  75. sub copy {
  76. my $class = shift;
  77. $class = shift if $class eq 'OLE';
  78. return OLE->SUPER::GetActiveObject($class);
  79. }
  80. sub AUTOLOAD {
  81. my $self = shift;
  82. my $retval;
  83. $AUTOLOAD =~ s/.*:://o;
  84. Carp::croak("Cannot autoload class method \"$AUTOLOAD\"")
  85. unless ref($self) && UNIVERSAL::isa($self,'OLE');
  86. local $^H = 0; # !hack alert!
  87. unless (defined $self->Dispatch($AUTOLOAD, $retval, @_)) {
  88. # Retry default method
  89. $self->Dispatch(undef, $retval, $AUTOLOAD, @_);
  90. }
  91. return $retval;
  92. }
  93. *CreateObject = \&new;
  94. *GetObject = \&copy;
  95. # Automation data types.
  96. sub VT_EMPTY {0;}
  97. sub VT_NULL {1;}
  98. sub VT_I2 {2;}
  99. sub VT_I4 {3;}
  100. sub VT_R4 {4;}
  101. sub VT_R8 {5;}
  102. sub VT_CY {6;}
  103. sub VT_DATE {7;}
  104. sub VT_BSTR {8;}
  105. sub VT_DISPATCH {9;}
  106. sub VT_ERROR {10;}
  107. sub VT_BOOL {11;}
  108. sub VT_VARIANT {12;}
  109. sub VT_UNKNOWN {13;}
  110. sub VT_I1 {16;}
  111. sub VT_UI1 {17;}
  112. sub VT_UI2 {18;}
  113. sub VT_UI4 {19;}
  114. sub VT_I8 {20;}
  115. sub VT_UI8 {21;}
  116. sub VT_INT {22;}
  117. sub VT_UINT {23;}
  118. sub VT_VOID {24;}
  119. sub VT_HRESULT {25;}
  120. sub VT_PTR {26;}
  121. sub VT_SAFEARRAY {27;}
  122. sub VT_CARRAY {28;}
  123. sub VT_USERDEFINED {29;}
  124. sub VT_LPSTR {30;}
  125. sub VT_LPWSTR {31;}
  126. sub VT_FILETIME {64;}
  127. sub VT_BLOB {65;}
  128. sub VT_STREAM {66;}
  129. sub VT_STORAGE {67;}
  130. sub VT_STREAMED_OBJECT {68;}
  131. sub VT_STORED_OBJECT {69;}
  132. sub VT_BLOB_OBJECT {70;}
  133. sub VT_CF {71;}
  134. sub VT_CLSID {72;}
  135. sub TKIND_ENUM {0;}
  136. sub TKIND_RECORD {1;}
  137. sub TKIND_MODULE {2;}
  138. sub TKIND_INTERFACE {3;}
  139. sub TKIND_DISPATCH {4;}
  140. sub TKIND_COCLASS {5;}
  141. sub TKIND_ALIAS {6;}
  142. sub TKIND_UNION {7;}
  143. sub TKIND_MAX {8;}
  144. 1;