diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/OLE.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/OLE.pm | 177 |
1 files changed, 177 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/OLE.pm b/Master/tlpkg/tlperl/lib/OLE.pm new file mode 100755 index 00000000000..234f6986ab3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/OLE.pm @@ -0,0 +1,177 @@ +# Compatibility layer for applications using the old toplevel OLE.pm. +# New code should use Win32::OLE + +# This file is based on ../lib/OLE.pm from ActiveState build 315. + +# Compatibility notes: +# - "GetObject" -> "GetActiveObject" +# - "keys %$collection" -> "Win32::OLE::Enum->All($collection)" +# or "in $Collection" +# - "unnamed" default method retries + +######################################################################## +# package Win32; +######################################################################## + +*Win32::OLELastError = sub { return OLE->LastError() }; + + +######################################################################## +package OLE::Variant; +######################################################################## + +use Win32::OLE qw(CP_ACP); +use Win32::OLE::Variant; + +use strict; +use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $_NewEnum $_Unique); +@ISA = qw(Win32::OLE::Variant); + +$Warn = 0; +$LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT +$CP = CP_ACP; +$_NewEnum = 0; +$_Unique = 0; + +sub new { + my $self = shift; + my $variant = $self->SUPER::new(@_); + $OLE::LastError = $Win32::OLE->LastError unless defined $variant; + return $variant; +} + + +######################################################################## +package OLE::Tie; +######################################################################## +use strict; +use vars qw(@ISA); +@ISA = qw(Win32::OLE::Tie); + +# !!! It is VERY important that Win32::OLE::Tie::DESTROY gets called. !!! +# If you subclass DESTROY, don't forget to call $self->SUPER::DESTROY. +# Otherwise the OLE interfaces will not be released until process termination! + +# Retry default method if property doesn't exist +sub FETCH { + my ($self,$key) = @_; + return $self->SUPER::Fetch($key, 1); +} + +sub STORE { + my ($self,$key,$value) = @_; + $self->SUPER::Store($key, $value, 1); +} + +# Enumerate collection members, not object properties +*FIRSTKEY = *Win32::OLE::Tie::FIRSTENUM; +*NEXTKEY = *Win32::OLE::Tie::NEXTENUM; + + +######################################################################## +package OLE; +######################################################################## +use Win32::OLE qw(CP_ACP); + +# Use OleInitialize() instead of CoInitializeEx: +Win32::OLE->Initialize(Win32::OLE::COINIT_OLEINITIALIZE); + +use strict; + +# Disable overload; unfortunately "no overload" doesn't do it :-( +# Overloading is no longer enabled by default in Win32::OLE +#use overload '""' => sub {overload::StrVal($_[0])}, +# '0+' => sub {overload::StrVal($_[0])}; + +use vars qw($AUTOLOAD @ISA $LCID $CP $Warn $LastError $Tie); +@ISA = qw(Win32::OLE); + +$Warn = 0; +$LCID = 2 << 10; # LOCALE_SYSTEM_DEFAULT +$CP = CP_ACP; +$Tie = 'OLE::Tie'; + +sub new { + my $class = shift; + $class = shift if $class eq 'OLE'; + return OLE->SUPER::new($class); +} + +sub copy { + my $class = shift; + $class = shift if $class eq 'OLE'; + return OLE->SUPER::GetActiveObject($class); +} + +sub AUTOLOAD { + my $self = shift; + my $retval; + $AUTOLOAD =~ s/.*:://o; + + Carp::croak("Cannot autoload class method \"$AUTOLOAD\"") + unless ref($self) && UNIVERSAL::isa($self,'OLE'); + + local $^H = 0; # !hack alert! + unless (defined $self->Dispatch($AUTOLOAD, $retval, @_)) { + # Retry default method + $self->Dispatch(undef, $retval, $AUTOLOAD, @_); + } + return $retval; +} + +*CreateObject = \&new; +*GetObject = \© + +# Automation data types. + +sub VT_EMPTY {0;} +sub VT_NULL {1;} +sub VT_I2 {2;} +sub VT_I4 {3;} +sub VT_R4 {4;} +sub VT_R8 {5;} +sub VT_CY {6;} +sub VT_DATE {7;} +sub VT_BSTR {8;} +sub VT_DISPATCH {9;} +sub VT_ERROR {10;} +sub VT_BOOL {11;} +sub VT_VARIANT {12;} +sub VT_UNKNOWN {13;} +sub VT_I1 {16;} +sub VT_UI1 {17;} +sub VT_UI2 {18;} +sub VT_UI4 {19;} +sub VT_I8 {20;} +sub VT_UI8 {21;} +sub VT_INT {22;} +sub VT_UINT {23;} +sub VT_VOID {24;} +sub VT_HRESULT {25;} +sub VT_PTR {26;} +sub VT_SAFEARRAY {27;} +sub VT_CARRAY {28;} +sub VT_USERDEFINED {29;} +sub VT_LPSTR {30;} +sub VT_LPWSTR {31;} +sub VT_FILETIME {64;} +sub VT_BLOB {65;} +sub VT_STREAM {66;} +sub VT_STORAGE {67;} +sub VT_STREAMED_OBJECT {68;} +sub VT_STORED_OBJECT {69;} +sub VT_BLOB_OBJECT {70;} +sub VT_CF {71;} +sub VT_CLSID {72;} + +sub TKIND_ENUM {0;} +sub TKIND_RECORD {1;} +sub TKIND_MODULE {2;} +sub TKIND_INTERFACE {3;} +sub TKIND_DISPATCH {4;} +sub TKIND_COCLASS {5;} +sub TKIND_ALIAS {6;} +sub TKIND_UNION {7;} +sub TKIND_MAX {8;} + +1; |