1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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;
|
