home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / Lite.pm < prev    next >
Text File  |  2002-07-08  |  6KB  |  225 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. if (defined &DB::sub && !defined $_Unique) {
  30.     warn "Win32::OLE operating in debugging mode: _Unique => 1\n";
  31.     $_Unique = 1;
  32. }
  33.  
  34. $Warn = 1;
  35.  
  36. sub CP_ACP   {0;}     # ANSI codepage
  37. sub CP_OEMCP {1;}     # OEM codepage
  38. sub CP_MACCP {2;}
  39. sub CP_UTF7  {65000;}
  40. sub CP_UTF8  {65001;}
  41.  
  42. sub DISPATCH_METHOD          {1;}
  43. sub DISPATCH_PROPERTYGET     {2;}
  44. sub DISPATCH_PROPERTYPUT     {4;}
  45. sub DISPATCH_PROPERTYPUTREF  {8;}
  46.  
  47. sub COINIT_MULTITHREADED     {0;}  # Default
  48. sub COINIT_APARTMENTTHREADED {2;}  # Use single threaded apartment model
  49.  
  50. # Bogus COINIT_* values to indicate special cases:
  51. sub COINIT_OLEINITIALIZE     {-1;} # Use OleInitialize instead of CoInitializeEx
  52. sub COINIT_NO_INITIALIZE     {-2;} # We are already initialized, just believe me
  53.  
  54. sub HRESULT {
  55.     my $hr = shift;
  56.     $hr -= 2**32 if $hr & 0x80000000;
  57.     return $hr;
  58. }
  59.  
  60. # CreateObject is defined here only because it is documented in the
  61. # "Learning Perl on Win32 Systems" Gecko book. Please use Win32::OLE->new().
  62. sub CreateObject {
  63.     if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
  64.     $AUTOLOAD = 'CreateObject';
  65.     goto &AUTOLOAD;
  66.     }
  67.  
  68.     # Hack to allow C<$obj = CreateObject Win32::OLE 'My.App';>. Although this
  69.     # is contrary to the Gecko, we just make it work since it doesn't hurt.
  70.     return Win32::OLE->new($_[1]) if $_[0] eq 'Win32::OLE';
  71.  
  72.     # Gecko form: C<$success = Win32::OLE::CreateObject('My.App',$obj);>
  73.     $_[1] = Win32::OLE->new($_[0]);
  74.     return defined $_[1];
  75. }
  76.  
  77. sub LastError {
  78.     unless (defined $_[0]) {
  79.     # Win32::OLE::LastError() will always return $Win32::OLE::LastError
  80.     return $LastError;
  81.     }
  82.  
  83.     if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
  84.     $AUTOLOAD = 'LastError';
  85.     goto &AUTOLOAD;
  86.     }
  87.  
  88.     #no strict 'refs';
  89.     my $LastError = "$_[0]::LastError";
  90.     $$LastError = $_[1] if defined $_[1];
  91.     return $$LastError;
  92. }
  93.  
  94. my $Options = "^(?:CP|LCID|Warn|_NewEnum|_Unique)\$";
  95.  
  96. sub Option {
  97.     if (ref($_[0]) && UNIVERSAL::isa($_[0],'Win32::OLE')) {
  98.     $AUTOLOAD = 'Option';
  99.     goto &AUTOLOAD;
  100.     }
  101.  
  102.     my $class = shift;
  103.  
  104.     if (@_ == 1) {
  105.     my $option = shift;
  106.     return ${"${class}::$option"} if $option =~ /$Options/o;
  107.     _croak("Invalid $class option: $option");
  108.     }
  109.  
  110.     while (@_) {
  111.     my ($option,$value) = splice @_, 0, 2;
  112.     _croak("Invalid $class option: $option") if $option !~ /$Options/o;
  113.     ${"${class}::$option"} = $value;
  114.     $class->_Unique() if $option eq "_Unique";
  115.     }
  116. }
  117.  
  118. sub Invoke {
  119.     my ($self,$method,@args) = @_;
  120.     $self->Dispatch($method, my $retval, @args);
  121.     return $retval;
  122. }
  123.  
  124. sub LetProperty {
  125.     my ($self,$method,@args) = @_;
  126.     $self->Dispatch([DISPATCH_PROPERTYPUT, $method], my $retval, @args);
  127.     return $retval;
  128. }
  129.  
  130. sub SetProperty {
  131.     my ($self,$method,@args) = @_;
  132.     my $wFlags = DISPATCH_PROPERTYPUT;
  133.     if (@args) {
  134.     # If the value is an object then it will be set by reference!
  135.     my $value = $args[-1];
  136.     if (UNIVERSAL::isa($value, 'Win32::OLE')) {
  137.         $wFlags = DISPATCH_PROPERTYPUTREF;
  138.     }
  139.     elsif (UNIVERSAL::isa($value,'Win32::OLE::Variant')) {
  140.         my $type = $value->Type & ~0xfff; # VT_TYPEMASK
  141.         # VT_DISPATCH and VT_UNKNOWN represent COM objects
  142.         $wFlags = DISPATCH_PROPERTYPUTREF if $type == 9 || $type == 13;
  143.     }
  144.     }
  145.     $self->Dispatch([$wFlags, $method], my $retval, @args);
  146.     return $retval;
  147. }
  148.  
  149. sub AUTOLOAD {
  150.     my $self = shift;
  151.     $AUTOLOAD = substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1;
  152.     _croak("Cannot autoload class method \"$AUTOLOAD\"")
  153.     unless ref($self) && UNIVERSAL::isa($self, 'Win32::OLE');
  154.     my $success = $self->Dispatch($AUTOLOAD, my $retval, @_);
  155.     unless (defined $success || ($^H & 0x200) != 0) {
  156.     # Retry default method if C<no strict 'subs';>
  157.     $self->Dispatch(undef, $retval, $AUTOLOAD, @_);
  158.     }
  159.     return $retval;
  160. }
  161.  
  162. sub in {
  163.     my @res;
  164.     while (@_) {
  165.     my $this = shift;
  166.     if (UNIVERSAL::isa($this, 'Win32::OLE')) {
  167.         push @res, Win32::OLE::Enum->All($this);
  168.     }
  169.     elsif (ref($this) eq 'ARRAY') {
  170.         push @res, @$this;
  171.     }
  172.     else {
  173.         push @res, $this;
  174.     }
  175.     }
  176.     return @res;
  177. }
  178.  
  179. sub valof {
  180.     my $arg = shift;
  181.     if (UNIVERSAL::isa($arg, 'Win32::OLE')) {
  182.     require Win32::OLE::Variant;
  183.     my ($class) = overload::StrVal($arg) =~ /^([^=]+)=/;
  184.     #no strict 'refs';
  185.     local $Win32::OLE::CP = ${"${class}::CP"};
  186.     local $Win32::OLE::LCID = ${"${class}::LCID"};
  187.     #use strict 'refs';
  188.     # VT_EMPTY variant for return code
  189.     my $variant = Win32::OLE::Variant->new;
  190.     $arg->Dispatch(undef, $variant);
  191.     return $variant->Value;
  192.     }
  193.     $arg = $arg->Value if UNIVERSAL::can($arg, 'Value');
  194.     return $arg;
  195. }
  196.  
  197. sub with {
  198.     my $object = shift;
  199.     while (@_) {
  200.     my $property = shift;
  201.     $object->{$property} = shift;
  202.     }
  203. }
  204.  
  205. ########################################################################
  206.  
  207. package Win32::OLE::Tie;
  208.  
  209. # Only retry default method under C<no strict 'subs';>
  210. sub FETCH {
  211.     my ($self,$key) = @_;
  212.     if ($key eq "_NewEnum") {
  213.     (my $class = ref $self) =~ s/::Tie$//;
  214.     return [Win32::OLE::Enum->All($self)] if ${"${class}::_NewEnum"};
  215.     }
  216.     $self->Fetch($key, !$Win32::OLE::Strict);
  217. }
  218.  
  219. sub STORE {
  220.     my ($self,$key,$value) = @_;
  221.     $self->Store($key, $value, !$Win32::OLE::Strict);
  222. }
  223.  
  224. 1;
  225.