view release on metacpan or  search on metacpan

lib/Win32/OLE/Lite.pm  view on Meta::CPAN

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"};
    }