home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _536fd85970cf3968612ce5e72e9bd0c9 < prev    next >
Text File  |  2000-03-15  |  4KB  |  176 lines
  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. sub OLELastError {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);
  28. @ISA = qw(Win32::OLE::Variant);
  29.  
  30. $Warn = 0;
  31. $LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT
  32. $CP = CP_ACP;
  33.  
  34. sub new {
  35.     my $self = shift;
  36.     my $variant = $self->SUPER::new(@_);
  37.     $OLE::LastError = $Win32::OLE->LastError unless defined $variant;
  38.     return $variant;
  39. }
  40.  
  41.  
  42. ########################################################################
  43. package OLE::Tie;
  44. ########################################################################
  45. use strict;
  46. use vars qw(@ISA);
  47. @ISA = qw(Win32::OLE::Tie);
  48.  
  49. # !!! It is VERY important that Win32::OLE::Tie::DESTROY gets called. !!!
  50. # If you subclass DESTROY, don't forget to call $self->SUPER::DESTROY.
  51. # Otherwise the OLE interfaces will not be released until process termination!
  52.  
  53. # Retry default method if property doesn't exist
  54. sub FETCH {
  55.     my ($self,$key) = @_;
  56.     return $self->SUPER::Fetch($key, 1);
  57. }
  58.  
  59. sub STORE {
  60.     my ($self,$key,$value) = @_;
  61.     $self->SUPER::Store($key, $value, 1);
  62. }
  63.  
  64. # Enumerate collection members, not object properties
  65. *FIRSTKEY = *Win32::OLE::Tie::FIRSTENUM;
  66. *NEXTKEY = *Win32::OLE::Tie::NEXTENUM;
  67.  
  68.  
  69. ########################################################################
  70. package OLE;
  71. ########################################################################
  72. use Win32::OLE qw(CP_ACP);
  73.  
  74. # Use OleInitialize() instead of CoInitializeEx:
  75. Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE);
  76.  
  77. use strict;
  78.  
  79. # Disable overload; unfortunately "no overload" doesn't do it :-(
  80. # Overloading is no longer enabled by default in Win32::OLE
  81. #use overload '""'     => sub {overload::StrVal($_[0])},
  82. #             '0+'     => sub {overload::StrVal($_[0])};
  83.  
  84. use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $Tie);
  85. @ISA = qw(Win32::OLE);
  86.  
  87. $Warn = 0;
  88. $LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT
  89. $CP = CP_ACP;
  90. $Tie = 'OLE::Tie';
  91.  
  92. sub new {
  93.     my $class = shift;
  94.     $class = shift if $class eq 'OLE';
  95.     return OLE->SUPER::new($class);
  96. }
  97.  
  98. sub copy {
  99.     my $class = shift;
  100.     $class = shift if $class eq 'OLE';
  101.     return OLE->SUPER::GetActiveObject($class);
  102. }
  103.  
  104. sub AUTOLOAD {
  105.     my $self = shift;
  106.     my $retval;
  107.     $AUTOLOAD =~ s/.*:://o;
  108.  
  109.     Carp::croak("Cannot autoload class method \"$AUTOLOAD\"") 
  110.       unless ref($self) && UNIVERSAL::isa($self,'OLE');
  111.  
  112.     local $^H = 0; # !hack alert!
  113.     unless (defined $self->Dispatch($AUTOLOAD, $retval, @_)) {
  114.     # Retry default method
  115.     $self->Dispatch(undef, $retval, $AUTOLOAD, @_);
  116.     }
  117.     return $retval;
  118. }
  119.  
  120. *CreateObject = \&new;
  121. *GetObject = \©
  122.  
  123. # Automation data types.
  124.  
  125. sub VT_EMPTY {0;}
  126. sub VT_NULL {1;}
  127. sub VT_I2 {2;}
  128. sub VT_I4 {3;}
  129. sub VT_R4 {4;}
  130. sub VT_R8 {5;}
  131. sub VT_CY {6;}
  132. sub VT_DATE {7;}
  133. sub VT_BSTR {8;}
  134. sub VT_DISPATCH {9;}
  135. sub VT_ERROR {10;}
  136. sub VT_BOOL {11;}
  137. sub VT_VARIANT {12;}
  138. sub VT_UNKNOWN {13;}
  139. sub VT_I1 {16;}
  140. sub VT_UI1 {17;}
  141. sub VT_UI2 {18;}
  142. sub VT_UI4 {19;}
  143. sub VT_I8 {20;}
  144. sub VT_UI8 {21;}
  145. sub VT_INT {22;}
  146. sub VT_UINT {23;}
  147. sub VT_VOID {24;}
  148. sub VT_HRESULT {25;}
  149. sub VT_PTR {26;}
  150. sub VT_SAFEARRAY {27;}
  151. sub VT_CARRAY {28;}
  152. sub VT_USERDEFINED {29;}
  153. sub VT_LPSTR {30;}
  154. sub VT_LPWSTR {31;}
  155. sub VT_FILETIME {64;}
  156. sub VT_BLOB {65;}
  157. sub VT_STREAM {66;}
  158. sub VT_STORAGE {67;}
  159. sub VT_STREAMED_OBJECT {68;}
  160. sub VT_STORED_OBJECT {69;}
  161. sub VT_BLOB_OBJECT {70;}
  162. sub VT_CF {71;}
  163. sub VT_CLSID {72;}
  164.  
  165. sub TKIND_ENUM {0;}
  166. sub TKIND_RECORD {1;}
  167. sub TKIND_MODULE {2;}
  168. sub TKIND_INTERFACE {3;}
  169. sub TKIND_DISPATCH {4;}
  170. sub TKIND_COCLASS {5;}
  171. sub TKIND_ALIAS {6;}
  172. sub TKIND_UNION {7;}
  173. sub TKIND_MAX {8;}
  174.  
  175. 1;
  176.