summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32/OLE/Lite.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/OLE/Lite.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/OLE/Lite.pm224
1 files changed, 224 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/OLE/Lite.pm b/Master/tlpkg/tlperl/lib/Win32/OLE/Lite.pm
new file mode 100644
index 00000000000..66b5e50ac0e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32/OLE/Lite.pm
@@ -0,0 +1,224 @@
+package Win32::OLE;
+
+sub _croak { require Carp; Carp::croak(@_) }
+
+unless (defined &Dispatch) {
+ DynaLoader::boot_DynaLoader('DynaLoader')
+ unless defined(&DynaLoader::dl_load_file);
+ my $file;
+ foreach my $dir (@INC) {
+ my $try = "$dir/auto/Win32/OLE/OLE.dll";
+ last if $file = (-f $try && $try);
+ }
+ _croak("Can't locate loadable object for module Win32::OLE".
+ " in \@INC (\@INC contains: @INC)")
+ unless $file; # wording similar to error from 'require'
+
+ my $libref = DynaLoader::dl_load_file($file, 0) or
+ _croak("Can't load '$file' for module Win32::OLE: ".
+ DynaLoader::dl_error()."\n");
+
+ my $boot_symbol_ref = DynaLoader::dl_find_symbol($libref, "boot_Win32__OLE")
+ or _croak("Can't find 'boot_Win32__OLE' symbol in $file\n");
+
+ my $xs = DynaLoader::dl_install_xsub("Win32::OLE::bootstrap",
+ $boot_symbol_ref, $file);
+ &$xs('Win32::OLE');
+}
+
+if (defined &DB::sub && !defined $_Unique) {
+ warn "Win32::OLE operating in debugging mode: _Unique => 1\n";
+ $_Unique = 1;
+}
+
+$Warn = 1;
+
+sub CP_ACP {0;} # ANSI codepage
+sub CP_OEMCP {1;} # OEM codepage
+sub CP_MACCP {2;}
+sub CP_UTF7 {65000;}
+sub CP_UTF8 {65001;}
+
+sub DISPATCH_METHOD {1;}
+sub DISPATCH_PROPERTYGET {2;}
+sub DISPATCH_PROPERTYPUT {4;}
+sub DISPATCH_PROPERTYPUTREF {8;}
+
+sub COINIT_MULTITHREADED {0;} # Default
+sub COINIT_APARTMENTTHREADED {2;} # Use single threaded apartment model
+
+# Bogus COINIT_* values to indicate special cases:
+sub COINIT_OLEINITIALIZE {-1;} # Use OleInitialize instead of CoInitializeEx
+sub COINIT_NO_INITIALIZE {-2;} # We are already initialized, just believe me
+
+sub HRESULT {
+ my $hr = shift;
+ $hr -= 2**32 if $hr & 0x80000000;
+ return $hr;
+}
+
+# CreateObject is defined here only because it is documented in the
+# "Learning Perl on Win32 Systems" Gecko book. Please use Win32::OLE->new().
+sub CreateObject {
+ if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
+ $AUTOLOAD = ref($_[0]) . '::CreateObject';
+ goto &AUTOLOAD;
+ }
+
+ # Hack to allow C<$obj = CreateObject Win32::OLE 'My.App';>. Although this
+ # is contrary to the Gecko, we just make it work since it doesn't hurt.
+ return Win32::OLE->new($_[1]) if $_[0] eq 'Win32::OLE';
+
+ # Gecko form: C<$success = Win32::OLE::CreateObject('My.App',$obj);>
+ $_[1] = Win32::OLE->new($_[0]);
+ return defined $_[1];
+}
+
+sub LastError {
+ unless (defined $_[0]) {
+ # Win32::OLE::LastError() will always return $Win32::OLE::LastError
+ return $LastError;
+ }
+
+ if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
+ $AUTOLOAD = ref($_[0]) . '::LastError';
+ goto &AUTOLOAD;
+ }
+
+ #no strict 'refs';
+ my $LastError = "$_[0]::LastError";
+ $$LastError = $_[1] if defined $_[1];
+ return $$LastError;
+}
+
+my $Options = "^(?:CP|LCID|Warn|Variant|_NewEnum|_Unique)\$";
+
+sub Option {
+ if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
+ $AUTOLOAD = ref($_[0]) . '::Option';
+ goto &AUTOLOAD;
+ }
+
+ my $class = shift;
+
+ if (@_ == 1) {
+ my $option = shift;
+ return ${"${class}::$option"} if $option =~ /$Options/o;
+ _croak("Invalid $class option: $option");
+ }
+
+ while (@_) {
+ my ($option,$value) = splice @_, 0, 2;
+ _croak("Invalid $class option: $option") if $option !~ /$Options/o;
+ ${"${class}::$option"} = $value;
+ $class->_Unique() if $option eq "_Unique";
+ }
+}
+
+sub Invoke {
+ my ($self,$method,@args) = @_;
+ $self->Dispatch($method, my $retval, @args);
+ return $retval;
+}
+
+sub LetProperty {
+ my ($self,$method,@args) = @_;
+ $self->Dispatch([DISPATCH_PROPERTYPUT, $method], my $retval, @args);
+ return $retval;
+}
+
+sub SetProperty {
+ my ($self,$method,@args) = @_;
+ my $wFlags = DISPATCH_PROPERTYPUT;
+ if (@args) {
+ # If the value is an object then it will be set by reference!
+ my $value = $args[-1];
+ if (UNIVERSAL::isa($value, 'Win32::OLE')) {
+ $wFlags = DISPATCH_PROPERTYPUTREF;
+ }
+ elsif (UNIVERSAL::isa($value,'Win32::OLE::Variant')) {
+ my $type = $value->Type & ~0xfff; # VT_TYPEMASK
+ # VT_DISPATCH and VT_UNKNOWN represent COM objects
+ $wFlags = DISPATCH_PROPERTYPUTREF if $type == 9 || $type == 13;
+ }
+ }
+ $self->Dispatch([$wFlags, $method], my $retval, @args);
+ return $retval;
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $autoload = substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1;
+ _croak("Cannot autoload class method \"$autoload\"")
+ unless ref($self) && UNIVERSAL::isa($self, 'Win32::OLE');
+ my $success = $self->Dispatch($autoload, my $retval, @_);
+ unless (defined $success || ($^H & 0x200) != 0) {
+ # Retry default method if C<no strict 'subs';>
+ $self->Dispatch(undef, $retval, $autoload, @_);
+ }
+ return $retval;
+}
+
+sub in {
+ my @res;
+ while (@_) {
+ my $this = shift;
+ if (UNIVERSAL::isa($this, 'Win32::OLE')) {
+ push @res, Win32::OLE::Enum->All($this);
+ }
+ elsif (ref($this) eq 'ARRAY') {
+ push @res, @$this;
+ }
+ else {
+ push @res, $this;
+ }
+ }
+ return @res;
+}
+
+sub valof {
+ my $arg = shift;
+ if (UNIVERSAL::isa($arg, 'Win32::OLE')) {
+ require Win32::OLE::Variant;
+ my ($class) = overload::StrVal($arg) =~ /^([^=]+)=/;
+ #no strict 'refs';
+ local $Win32::OLE::CP = ${"${class}::CP"};
+ local $Win32::OLE::LCID = ${"${class}::LCID"};
+ #use strict 'refs';
+ # VT_EMPTY variant for return code
+ my $variant = Win32::OLE::Variant->new;
+ $arg->Dispatch(undef, $variant);
+ return $variant->Value;
+ }
+ $arg = $arg->Value if UNIVERSAL::can($arg, 'Value');
+ return $arg;
+}
+
+sub with {
+ my $object = shift;
+ while (@_) {
+ my $property = shift;
+ $object->{$property} = shift;
+ }
+}
+
+########################################################################
+
+package Win32::OLE::Tie;
+
+# Only retry default method under C<no strict 'subs';>
+sub FETCH {
+ my ($self,$key) = @_;
+ if ($key eq "_NewEnum") {
+ (my $class = ref $self) =~ s/::Tie$//;
+ return [Win32::OLE::Enum->All($self)] if ${"${class}::_NewEnum"};
+ }
+ $self->Fetch($key, !$Win32::OLE::Strict);
+}
+
+sub STORE {
+ my ($self,$key,$value) = @_;
+ $self->Store($key, $value, !$Win32::OLE::Strict);
+}
+
+1;