home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / site / lib / OLE.pm < prev    next >
Encoding:
Perl POD Document  |  2000-05-22  |  4.4 KB  |  178 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 $_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.