home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _3a7131e864671501973feb2db3902a9b < prev    next >
Encoding:
Text File  |  2000-03-15  |  6.0 KB  |  222 lines
  1. package Win32::OLE;
  2.  
  3. sub _croak { require Carp; Carp::croak(@_) }
  4.  
  5. unless (defined &Dispatch) {
  6.     DynaLoader::boot_DynaLoader('DynaLoader')
  7.         unless defined(&DynaLoader::dl_load_file);
  8.     my $file;
  9.     foreach my $dir (@INC) {
  10.     my $try = "$dir/auto/Win32/OLE/OLE.dll";
  11.     last if $file = (-f $try && $try);
  12.     }
  13.     _croak("Can't locate loadable object for module Win32::OLE".
  14.        " in \@INC (\@INC contains: @INC)")
  15.     unless $file;    # wording similar to error from 'require'
  16.  
  17.     my $libref = DynaLoader::dl_load_file($file, 0) or
  18.     _croak("Can't load '$file' for module Win32::OLE: ".
  19.            DynaLoader::dl_error()."\n");
  20.  
  21.     my $boot_symbol_ref = DynaLoader::dl_find_symbol($libref, "boot_Win32__OLE")
  22.     or _croak("Can't find 'boot_Win32__OLE' symbol in $file\n");
  23.  
  24.     my $xs = DynaLoader::dl_install_xsub("Win32::OLE::bootstrap",
  25.                      $boot_symbol_ref, $file);
  26.     &$xs('Win32::OLE');
  27. }
  28.  
  29. $Strict = ($^H & 0x200) != 0; # strict 'subs' in effect?
  30. $Warn = 1;
  31.  
  32. sub CP_ACP   {0;}     # ANSI codepage
  33. sub CP_OEMCP {1;}     # OEM codepage
  34. sub CP_MACCP {2;}
  35. sub CP_UTF7  {65000;}
  36. sub CP_UTF8  {65001;}
  37.  
  38. sub DISPATCH_METHOD          {1;}
  39. sub DISPATCH_PROPERTYGET     {2;}
  40. sub DISPATCH_PROPERTYPUT     {4;}
  41. sub DISPATCH_PROPERTYPUTREF  {8;}
  42.  
  43. sub COINIT_MULTITHREADED     {0;}  # Default
  44. sub COINIT_APARTMENTTHREADED {2;}  # Use single threaded apartment model
  45.  
  46. # Bogus COINIT_* values to indicate special cases:
  47. sub COINIT_OLEINITIALIZE     {-1;} # Use OleInitialize instead of CoInitializeEx
  48. sub COINIT_NO_INITIALIZE     {-2;} # We are already initialized, just believe me
  49.  
  50. sub HRESULT {
  51.     my $hr = shift;
  52.     $hr -= 2**32 if $hr & 0x80000000;
  53.     return $hr;
  54. }
  55.  
  56. # CreateObject is defined here only because it is documented in the
  57. # "Learning Perl on Win32 Systems" Gecko book. Please use Win32::OLE->new().
  58. sub CreateObject {
  59.     if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
  60.     $AUTOLOAD = 'CreateObject';
  61.     goto &AUTOLOAD;
  62.     }
  63.  
  64.     # Hack to allow C<$obj = CreateObject Win32::OLE 'My.App';>. Although this
  65.     # is contrary to the Gecko, we just make it work since it doesn't hurt.
  66.     return Win32::OLE->new($_[1]) if $_[0] eq 'Win32::OLE';
  67.  
  68.     # Gecko form: C<$success = Win32::OLE::CreateObject('My.App',$obj);>
  69.     $_[1] = Win32::OLE->new($_[0]);
  70.     return defined $_[1];
  71. }
  72.  
  73. sub LastError {
  74.     unless (defined $_[0]) {
  75.     # Win32::OLE::LastError() will always return $Win32::OLE::LastError
  76.     return $LastError;
  77.     }
  78.  
  79.     if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
  80.     $AUTOLOAD = 'LastError';
  81.     goto &AUTOLOAD;
  82.     }
  83.  
  84.     #no strict 'refs';
  85.     my $LastError = "$_[0]::LastError";
  86.     $$LastError = $_[1] if defined $_[1];
  87.     return $$LastError;
  88. }
  89.  
  90. sub Option {
  91.     if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
  92.     $AUTOLOAD = 'Option';
  93.     goto &AUTOLOAD;
  94.     }
  95.  
  96.     shift; # class name
  97.  
  98.     if (@_ == 1) {
  99.     my $Option = shift;
  100.     $Option eq "CP"     && return $CP;
  101.     $Option eq "LCID"   && return $LCID;
  102.     $Option eq "Strict" && return $Strict; # Intentionally undocumented!
  103.     $Option eq "Warn"   && return $Warn;
  104.     _croak("Invalid Win32::OLE option: $Option");
  105.     }
  106.  
  107.     while (@_) {
  108.     my ($Option,$Value) = splice @_, 0, 2;
  109.     if    ($Option eq "CP")     { $CP = $Value; }
  110.     elsif ($Option eq "LCID")   { $LCID = $Value; }
  111.     elsif ($Option eq "Strict") { $Strict = $Value; }
  112.     elsif ($Option eq "Warn")   { $Warn = $Value; }
  113.     else {
  114.         _croak("Invalid Win32::OLE option: $Option");
  115.     }
  116.     }
  117. }
  118.  
  119. sub Invoke {
  120.     my ($self,$method,@args) = @_;
  121.     $self->Dispatch($method, my $retval, @args);
  122.     return $retval;
  123. }
  124.  
  125. sub LetProperty {
  126.     my ($self,$method,@args) = @_;
  127.     $self->Dispatch([DISPATCH_PROPERTYPUT, $method], my $retval, @args);
  128.     return $retval;
  129. }
  130.  
  131. sub SetProperty {
  132.     my ($self,$method,@args) = @_;
  133.     my $wFlags = DISPATCH_PROPERTYPUT;
  134.     if (@args) {
  135.     # If the value is an object then it will be set by reference!
  136.     my $value = $args[-1];
  137.     if (UNIVERSAL::isa($value, 'Win32::OLE')) {
  138.         $wFlags = DISPATCH_PROPERTYPUTREF;
  139.     }
  140.     elsif (UNIVERSAL::isa($value,'Win32::OLE::Variant')) {
  141.         my $type = $value->Type & ~0xfff; # VT_TYPEMASK
  142.         # VT_DISPATCH and VT_UNKNOWN represent COM objects
  143.         $wFlags = DISPATCH_PROPERTYPUTREF if $type == 9 || $type == 13;
  144.     }
  145.     }
  146.     $self->Dispatch([$wFlags, $method], my $retval, @args);
  147.     return $retval;
  148. }
  149.  
  150. sub AUTOLOAD {
  151.     my $self = shift;
  152.     $AUTOLOAD =~ s/.*:://o;
  153.     _croak("Cannot autoload class method \"$AUTOLOAD\"") 
  154.       unless ref($self) && UNIVERSAL::isa($self, 'Win32::OLE');
  155.     my $success = $self->Dispatch($AUTOLOAD, my $retval, @_);
  156.     unless (defined $success || $Strict) {
  157.     # Retry default method if C<no strict 'subs';>
  158.     $self->Dispatch(undef, $retval, $AUTOLOAD, @_);
  159.     }
  160.     return $retval;
  161. }
  162.  
  163. sub in {
  164.     my @res;
  165.     while (@_) {
  166.     my $this = shift;
  167.     if (UNIVERSAL::isa($this, 'Win32::OLE')) {
  168.         push @res, Win32::OLE::Enum->All($this);
  169.     }
  170.     elsif (ref($this) eq 'ARRAY') {
  171.         push @res, @$this;
  172.     }
  173.     else {
  174.         push @res, $this;
  175.     }
  176.     }
  177.     return @res;
  178. }
  179.  
  180. sub valof {
  181.     my $arg = shift;
  182.     if (UNIVERSAL::isa($arg, 'Win32::OLE')) {
  183.     require Win32::OLE::Variant;
  184.     my ($class) = overload::StrVal($arg) =~ /^([^=]+)=/;
  185.     #no strict 'refs';
  186.     local $Win32::OLE::CP = ${$class."::CP"};
  187.     local $Win32::OLE::LCID = ${$class."::LCID"};
  188.     #use strict 'refs';
  189.     # VT_EMPTY variant for return code
  190.     my $variant = Win32::OLE::Variant->new;
  191.     $arg->Dispatch(undef, $variant);
  192.     return $variant->Value;
  193.     }
  194.     $arg = $arg->Value if UNIVERSAL::can($arg, 'Value');
  195.     return $arg;
  196. }
  197.  
  198. sub with {
  199.     my $object = shift;
  200.     while (@_) {
  201.     my $property = shift;
  202.     $object->{$property} = shift;
  203.     }
  204. }
  205.  
  206. ########################################################################
  207.  
  208. package Win32::OLE::Tie;
  209.  
  210. # Only retry default method under C<no strict 'subs';>
  211. sub FETCH {
  212.     my ($self,$key) = @_;
  213.     $self->Fetch($key, !$Win32::OLE::Strict);
  214. }
  215.  
  216. sub STORE {
  217.     my ($self,$key,$value) = @_;
  218.     $self->Store($key, $value, !$Win32::OLE::Strict);
  219. }
  220.  
  221. 1;
  222.