diff options
author | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2016-04-05 22:27:26 +0000 |
commit | b56b320b5e2515160073fa1b469514002688fe11 (patch) | |
tree | 965a7100c5e45fca8ec803d22b8b6ce14fca4633 /Master/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm | |
parent | d26c206452d2e285c3bbf949f34011e4a55fd8f9 (diff) |
tlperl 5.22.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm')
-rw-r--r-- | Master/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm | 224 |
1 files changed, 224 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm b/Master/tlpkg/tlperl/site/lib/Win32/OLE/Lite.pm new file mode 100644 index 00000000000..66b5e50ac0e --- /dev/null +++ b/Master/tlpkg/tlperl/site/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; |