use Test::More skip_all => " *** NOT IMPLEMENTED";
########################################################################
#
# Test Win32::OLE.pm module using MS Excel
#
########################################################################
# If you rearrange the tests, please renumber:
# perl -i.bak -pe "++$t if !$t || s/^# \d+\./# $t./" 3_ole.t
########################################################################
package Excel;
use strict;
use Win32::OLE;
use strict qw(vars);
use vars qw($AUTOLOAD @ISA $Warn $LastError $CP $LCID $Tie $Variant);
# use BEGIN because the class is already used in BEGIN block later
BEGIN {
@ISA = qw(Win32::OLE);
$CP = Win32::OLE->Option('CP');
$LCID = Win32::OLE->Option('LCID');
# This is necessary to get the _NewEnum property access working!
$Tie = "Excel::Tie";
@Excel::Tie::ISA = qw(Win32::OLE::Tie);
@Excel::Variant::ISA = qw(Win32::OLE::Variant);
}
sub AUTOLOAD {
my $self = shift;
$AUTOLOAD = "SUPER::" . substr $AUTOLOAD, rindex($AUTOLOAD, ':')+1;
my $retval = $self->$AUTOLOAD(@_);
return $retval if defined($retval) || $AUTOLOAD eq 'DESTROY';
printf "# $AUTOLOAD returned OLE error 0x%08x\n", $LastError;
$::Fail = $::Test;
return;
}
########################################################################
package main;
use strict;
no warnings "utf8";
use Cwd;
use FileHandle;
use Sys::Hostname;
use Win32::OLE qw(CP_ACP CP_OEMCP CP_UTF8 HRESULT in valof with);
use Win32::OLE::NLS qw(:DEFAULT :LANG :SUBLANG);
use Win32::OLE::Variant;
$Excel::Variant = 1;
$Excel::CP = CP_UTF8;
use vars qw($Test $Fail);
$^W = 1;
STDOUT->autoflush(1);
STDERR->autoflush(1);
open(ME,$0) or die $!;
my $TestCount = grep(/\+\+\$Test/,<ME>);
close(ME);
sub stringify {
my $arg = shift;
return "<undef>" unless defined $arg;
if (ref $arg eq 'ARRAY') {
my $res;
foreach my $elem (@$arg) {
$res .= "," if defined $res;
$res .= stringify($elem);
}
return "[$res]";
}
return "$arg";
}
sub Quit {
$_[0]->Win32::OLE::Quit;
print "not " unless ++$Test == $TestCount;
print "ok $TestCount\n";
}
# 1. Create a new Excel automation server
my $Excel;
BEGIN {
$Excel::Warn = 0;
$Excel = Excel->new('Excel.Application', \&Quit);
$Excel::Warn = 2;
unless (defined $Excel) {
my $Msg = Excel->LastError;
chomp $Msg;
$Msg =~ s/\n/\n\# /g;
print "# $Msg\n";
print "1..0 # skip Excel.Application not installed\n";
exit 0;
}
}
# We only ever get here if Excel is actually installed
use Win32::OLE::Const ('Microsoft Excel');
$Test = 0;
print "1..$TestCount\n";
my $File = cwd . "\\test.xls";
if ($^O eq 'cygwin') {
$File =~ s#\\#/#g;
chomp($File = `cygpath -w '$File'`);
}
# Excel 2007 doesn't handle forward slashes anymore...
$File =~ s#/#\\#g;
unlink $File if -f $File;
print "# File is '$File'\n";
printf "# Excel is %s\n", $Excel;
my $Type = Win32::OLE->QueryObjectType($Excel);
print "# App object type is $Type\n";
printf "ok %d\n", ++$Test;
# 2. Make sure the CreateObject function works too
my $Obj;
my $Value = Win32::OLE::CreateObject('Excel.Application', $Obj);
print "not " unless $Value && UNIVERSAL::isa($Obj, 'Win32::OLE');
printf "ok %d\n", ++$Test;
$Obj->Quit if defined $Obj;
# 3. Add a workbook (with default number of sheets)
$Excel->{SheetsInNewWorkbook} = 3;
my $Book = $Excel->Workbooks->Add;
$Type = Win32::OLE->QueryObjectType($Book);
print "# Book object type is $Type\n";
print "not " unless defined $Book;
printf "ok %d\n", ++$Test;
# 4. Test if class is inherited by objects created through $Excel
print "not " unless UNIVERSAL::isa($Book,'Excel');
printf "ok %d\n", ++$Test;
# 5. Generate OLE error, should be "croaked" by Win32::OLE
eval { local $Excel::Warn = 3; $Book->Xyzzy(223); };
my $Msg = $@;
chomp $Msg;
$Msg =~ s/\n/\n\# /g;
print "# Died with msg:\n# $Msg\n";
print "not " unless $@;
printf "ok %d\n", ++$Test;
# 6. Generate OLE error, should be trapped by Excel subclass
$Fail = -1;
{ local $Excel::Warn = 0; $Book->Xyzzy(223); };
printf "# Excel::LastError returns (num): 0x%08x\n", Excel->LastError();
$Msg = Excel->LastError();
$Msg =~ s/\n/\n\# /g;
printf "# Excel::LastError returns (str):\n# $Msg\n";
Excel->LastError(0);
printf "# Excel::LastError returns (num): 0x%08x\n", Excel->LastError();
printf "# Excel::LastError returns (str): %s\n", Excel->LastError();
print "not " if $Fail != $Test;
printf "ok %d\n", ++$Test;
# 7. Set 'Warn' option to subroutine reference
$Msg = '';
Excel->Option(Warn => sub {goto Error});
$Book->Plugh(42);
$Msg = "not ";
Error:
printf "${Msg}ok %d\n", ++$Test;
Excel->Option(Warn => 2);
# 8. Get an object for 1st worksheet
my $Sheet = $Book->Worksheets(1);
$Type = Win32::OLE->QueryObjectType($Sheet);
print "# Sheet object type is $Type\n";
print "not " unless defined $Sheet;
printf "ok %d\n", ++$Test;
# 9. Catch "invalid type" error, test if index is correct
{ local $Excel::Warn = 0; $Sheet->Cells(1, $Sheet); };
$Msg = Excel->LastError();
$Msg =~ s/\n/\n\# /g;
printf "# Excel::LastError returns (str):\n# $Msg\n";
print "not " unless $Msg =~ /"Cells" argument 2/;
printf "ok %d\n", ++$Test;
# 10. Test the "with" function
printf("# Tests %d and %d will fail if no default printer has been installed yet\n",
$Test+1, $Test+2);
with($Sheet->PageSetup, Orientation => xlLandscape, FirstPageNumber => 13);
$Value = $Sheet->PageSetup->FirstPageNumber;
print "# FirstPageNumber is \"$Value\"\n";
print "not " unless $Value == 13;
printf "ok %d\n", ++$Test;
# 11. Test constant value: xlLandscape should be "2"
$Value = $Sheet->PageSetup->Orientation;
print "# Orientation is \"$Value\"\n";
print "not " unless $Value == 2;
printf "ok %d\n", ++$Test;
# 12. Test Win32::OLE::Const->Load method
my $xl = Win32::OLE::Const->Load('Microsoft Excel');
printf "# xlLandscape is \"%s\"\n", $xl->{'xlLandscape'};
print "not " unless $xl->{'xlLandscape'} == 2;
printf "ok %d\n", ++$Test;
# 13. Call a method with a magical scalar as argument
my $Sheets = $Book->Worksheets;
my $Name = $Book->Worksheets($Sheets->{Count})->{Name};
print "# Name is \"$Name\"\n";
print "not " unless $Name;
printf "ok %d\n", ++$Test;
# 14. Set values of some cells and retrieve a value
$Sheet->{Name} = 'My Sheet #1';
foreach my $i (1..10) {
$Sheet->Cells($i,$i)->{Value} = $i**2;
}
my $Cell = $Sheet->Cells(5,5);
$Type = Win32::OLE->QueryObjectType($Cell);
printf "# Cells (%s) object type is $Type\n", ref($Cell);
$Value = $Cell->{Value};
print "# Value is \"$Value\"\n";
print "not " unless $Cell->{Value} == 25;
printf "ok %d\n", ++$Test;
# 15. Call OLE method with $1 as argument
# This test is commented out because Perl doesn't set POK on $1,
# it seems to be only pPOK, which still gets translated to undef. :(
#Excel->Option(Warn => 0);
#$_ = "The formula is MIN(77,33,55)";
#print "# Expression is \"$1\"\n" if /is (.*)/;
##$Value = $Sheet->Evaluate("MIN(77,33,55)") if /is (.*)/;
#$Value = $Sheet->Evaluate($1) if /is (.*)/;
#Excel->Option(Warn => 2);
#$Value = "" unless defined $Value;
#print "# Value is \"$Value\"\n";
#print "not " unless $Value eq "33";
printf "ok %d\n", ++$Test;
# 16. Test the valof function
my $RefOf = $Cell;
my $ValOf = valof $Cell;
$Cell->{Value} = 27;
print "not " unless $ValOf == 25 && $RefOf->Value == 27;
printf "ok %d\n", ++$Test;
# 17. Assign and retrieve a very long string
$Cell->{Value} = 'a' x 300;
printf "# Value is %s\n", $Cell->Value;
print "not " unless $Cell->Value eq ('a' x 300);
printf "ok %d\n", ++$Test;
# 18. Assign a substr() magical lvalue (doesn't get POK bit set)
$Cell->Dispatch([Win32::OLE::DISPATCH_PROPERTYPUT, 'Value'],
my $retval, substr('xyz', 0, 1));
printf "# Value is %s\n", $Cell->Value;
print "not " unless $Cell->Value eq 'x';
printf "ok %d\n", ++$Test;
# 19. Try to roundtrip a VT_CY value and see if it stays a Variant
$Cell->{Value} = Variant(VT_CY, 1.25);
$Value = $Cell->{Value};
printf "# Value is %s, ref=%s, type=%d\n", $Value, ref $Value, $Value->Type;
print "not " unless $Cell->Value == 1.25 &&
ref($Value) eq "Excel::Variant" &&
$Value->Type == VT_CY;
printf "ok %d\n", ++$Test;
# 20. Test 'SetProperty' function
$Cell->SetProperty('Value', 4711);
printf "# Value is %s\n", $Cell->Value;
print "not " unless $Cell->Value == 4711;
printf "ok %d\n", ++$Test;
# 21. The following tests rely on the fact that the font is not yet bold
printf "# Bold: %s\n", $Cell->Style->Font->Bold;
print "not " if $Cell->Style->Font->Bold;
printf "ok %d\n", ++$Test;
# 22. Assignment by DISPATCH_PROPERTYPUTREF shouldn't work
my $Style = $Book->Styles->Add("MyStyle");
$Style->Font->{Bold} = 1;
{ local $Excel::Warn = 0; $Cell->{Style} = $Style }
my $LastError = Excel->LastError;
printf "# Bold: %s\n", $Cell->Style->Font->Bold;
printf "# Excel->LastError is 0x%x\n", $LastError;
print "not " if $LastError != HRESULT(0x80020003) || $Cell->Style->Font->Bold;
printf "ok %d\n", ++$Test;
# 23. But DISPATCH_PROPERTYPUT should be ok
$Cell->LetProperty('Style', $Style);
printf "# Bold: %s\n", $Cell->Style->Font->Bold;
print "not " unless $Cell->Style->Font->Bold;
printf "ok %d\n", ++$Test;
# 24. Set a cell range from an array ref containing an IV, PV and NV
$Sheet->Range("A8:C9")->{Value} = [[undef, 'Camel', "\x{263a}"],[42, 'Perl', 3.1415]];
$Value = $Sheet->Cells(9,2)->Value . $Sheet->Cells(8,2)->Value;
print "# Value is \"$Value\"\n";
print "not " unless $Value eq 'PerlCamel';
printf "ok %d\n", ++$Test;
# 25. Retrieve float value (esp. interesting in foreign locales)
$Value = $Sheet->Cells(9,3)->{Value};
print "# Value is \"$Value\"\n";
print "not " unless $Value == 3.1415;
printf "ok %d\n", ++$Test;
# 26. Retrieve unicode value.
$Value = $Sheet->Cells(8,3)->{Value};
print "# Value is \"$Value\"\n";
print "not " unless $Value eq "\x{263a}";
printf "ok %d\n", ++$Test;
# 27. Make sure the length of the unicode string is correct.
$Value = $Sheet->Cells(8,3)->{Value};
print "# length(Value) is ", length($Value), "\n";
print "not " unless length($Value) == length("\x{263a}");
printf "ok %d\n", ++$Test;
# 28. Use Unicode::String object to assign BSTR value
eval { require Unicode::String };
++$Test;
if ($@) {
printf "ok %d # skip Unicode::String module not installed\n", $Test;
}
else {
$Sheet->Cells(1,3)->{Value} = Unicode::String::utf8("\342\230\272");
$Value = $Sheet->Cells(1,3)->{Value};
print "# Value is \"$Value\"\n";
print "not " unless $Value eq "\x{263a}" && length($Value) == 1;
printf "ok %d\n", $Test;
}
# 29. Retrieve a 0 dimensional range; check array data structure
$Value = $Sheet->Range("B8")->{Value};
printf "# Values are: \"%s\"\n", stringify($Value);
print "not " if ref $Value;
printf "ok %d\n", ++$Test;
# 30. Retrieve a 1 dimensional row range; check array data structure
$Value = $Sheet->Range("B8:C8")->{Value};
printf "# Values are: \"%s\"\n", stringify($Value);
print "not " unless @$Value == 1 && ref $$Value[0];
printf "ok %d\n", ++$Test;
# 31. Retrieve a 1 dimensional column range; check array data structure
$Value = $Sheet->Range("B8:B9")->{Value};
printf "# Values are: \"%s\"\n", stringify($Value);
print "not " unless @$Value == 2 && ref $$Value[0] && ref $$Value[1];
printf "ok %d\n", ++$Test;
# 32. Retrieve a 2 dimensional range; check array data structure
$Value = $Sheet->Range("B8:C9")->{Value};
printf "# Values are: \"%s\"\n", stringify($Value);
print "not " unless @$Value == 2 && ref $$Value[0] && ref $$Value[1];
printf "ok %d\n", ++$Test;
# 33. Check contents of 2 dimensional array
$Value = $$Value[0][0] . $$Value[1][0] . $$Value[1][1];
print "# Value is \"$Value\"\n";
print "not " unless $Value eq 'CamelPerl3.1415';
printf "ok %d\n", ++$Test;
# 34. Set a cell formula and retrieve calculated value
$Sheet->Cells(3,1)->{Formula} = '=PI()';
$Value = $Sheet->Cells(3,1)->{Value};
print "# Value is \"$Value\"\n";
print "not " unless abs($Value-3.141592) < 0.00001;
printf "ok %d\n", ++$Test;
# 35. Add single worksheet and check that worksheet count is incremented
my $Count = $Sheets->{Count};
$Book->Worksheets->Add;
$Value = $Sheets->{Count};
print "# Count is \"$Count\" and Value is \"$Value\"\n";
print "not " unless $Value == $Count+1;
printf "ok %d\n", ++$Test;
# 36. Add 2 more sheets, optional arguments are omitted
$Count = $Sheets->{Count};
$Book->Worksheets->Add(undef,undef,2);
$Value = $Sheets->{Count};
print "# Count is \"$Count\" and Value is \"$Value\"\n";
print "not " unless $Value == $Count+2;
printf "ok %d\n", ++$Test;
# 37. Add 3 more sheets before sheet 2 using a named argument
$Count = $Sheets->{Count};
$Book->Worksheets(2)->{Name} = 'XYZZY';
$Sheets->Add($Book->Worksheets(2), {Count => 3});
$Value = $Sheets->{Count};
print "# Count is \"$Count\" and Value is \"$Value\"\n";
print "not " unless $Value == $Count+3;
printf "ok %d\n", ++$Test;
# 38. Previous sheet 2 should now be sheet 5
$Value = $Book->Worksheets(5)->{Name};
print "# Value is \"$Value\"\n";
print "not " unless $Value eq 'XYZZY';
printf "ok %d\n", ++$Test;
# 39. Add 2 more sheets at the end using 2 named arguments
$Count = $Sheets->{Count};
# Following line doesn't work with Excel 7 (Seems like an Excel bug?)
# $Sheets->Add({Count => 2, After => $Book->Worksheets($Sheets->{Count})});
$Sheets->Add({Count => 2, After => $Book->Worksheets($Sheets->{Count}-1)});
print "not " unless $Sheets->{Count} == $Count+2;
printf "ok %d\n", ++$Test;
# 40. Number of objects in an enumeration must match its "Count" property
my @Sheets = in $Sheets;
printf "# \$Sheets->{Count} is %d\n", $Sheets->{Count};
printf "# scalar(\@Sheets) is %d\n", scalar(@Sheets);
foreach my $Sheet (@Sheets) {
printf "# Sheet->{Name} is \"%s\"\n", $Sheet->{Name};
}
print "not " unless $Sheets->{Count} == @Sheets;
printf "ok %d\n", ++$Test;
undef @Sheets;
# 41. Enumerate all application properties using the C<keys> function
my @Properties = keys %$Excel;
printf "# Number of Excel application properties: %d\n", scalar(@Properties);
$Value = grep /^(Parent|Xyzzy|Name)$/, @Properties;
print "# Value is \"$Value\"\n";
print "not " unless $Value == 2;
printf "ok %d\n", ++$Test;
undef @Properties;
# 42. Translate character from ANSI -> OEM
my ($Version) = $Excel->{Version} =~ /([0-9.]+)/;
print "# Excel version is $Version\n";
my $LCID = MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL));
$LCID = MAKELCID(MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL)) if $Version >= 8;
$Excel::LCID = $LCID;
$Cell = $Book->Worksheets('My Sheet #1')->Cells(1,5);
$Cell->{Formula} = '=CHAR(163)';
$Excel::CP = CP_ACP;
my $ANSI = valof $Cell;
$Excel::CP = CP_OEMCP;
my $OEM = valof $Cell;
print "# ANSI(cp1252) -> OEM(cp437/cp850): 163 -> 156\n";
printf "# ANSI is \"$ANSI\" (%d) and OEM is \"$OEM\" (%d)\n", ord($ANSI), ord($OEM);
print "not " unless ord($ANSI) == 163 && ord($OEM) == 156;
printf "ok %d\n", ++$Test;
# 43. Save workbook to file
print "not " unless $Book->SaveAs($File);
printf "ok %d\n", ++$Test;
# 44. Check if output file exists.
print "not " unless -f $File;
printf "ok %d\n", ++$Test;
# 45. Access the same file object through a moniker.
$Obj = Win32::OLE->GetObject($File);
for ($Count=0 ; $Count < 5 ; ++$Count) {
my $Type = Win32::OLE->QueryObjectType($Obj);
print "# Object type is \"$Type\"\n";
last if $Type =~ /Workbook/;
$Obj = $Obj->{Parent};
}
$Value = 2.7172;
eval { $Value = $Obj->Worksheets('My Sheet #1')->Range('A3')->{Value}; };
print "# Value is \"$Value\"\n";
print "not " unless abs($Value-3.141592) < 0.00001;
printf "ok %d\n", ++$Test;
# 46. Get return value as Win32::OLE::Variant object
$Cell = $Obj->Worksheets('My Sheet #1')->Range('B9');
my $Variant = Win32::OLE::Variant->new(VT_EMPTY);
$Cell->Dispatch('Value', $Variant);
printf "# Variant is (%s,%s)\n", $Variant->Type, $Variant->Value;
print "not " unless $Variant->Type == VT_BSTR && $Variant->Value eq 'Perl';
printf "ok %d\n", ++$Test;
# 47. Use clsid string to start OLE server
undef $Value;
eval {
require Win32::Registry;
Win32::Registry->import(qw(RegOpenKeyEx KEY_READ));
use vars qw($HKEY_CLASSES_ROOT);
# Use Win32::Registry internals to open registry key in readonly mode
RegOpenKeyEx($HKEY_CLASSES_ROOT->{handle}, 'Excel.Application\CLSID',
undef, KEY_READ(), my $HKey);
$HKey = Win32::Registry::_new($HKey);
$HKey->QueryValue('', my $CLSID);
$HKey->Close;
print "# Excel CLSID is $CLSID\n";
$Obj = Win32::OLE->new($CLSID);
$Value = (Win32::OLE->QueryObjectType($Obj))[0];
$Obj->Quit if $Value eq 'Excel';
};
++$Test;
if ($@) {
printf "ok %d # skip Registry problem $@\n", $Test;
}
else {
print "# Object application is $Value\n";
print "not " unless $Value eq 'Excel';
printf "ok %d\n", $Test;
}
# 48. Use DCOM syntax to start server (on local machine though)
# This might fail (on Win95/NT3.5 if DCOM support is not installed.
$Obj = Win32::OLE->new([hostname, 'Excel.Application'], 'Quit');
$Value = (Win32::OLE->QueryObjectType($Obj))[0];
print "# Object application is $Value\n";
print "not " unless $Value eq 'Excel';
printf "ok %d\n", ++$Test;
# 49. Find $Excel object via EnumAllObjects()
my $Found = 0;
$Count = Win32::OLE->EnumAllObjects(sub {
my $Object = shift;
my $Class = Win32::OLE->QueryObjectType($Object);
$Class = "" unless defined $Class;
printf "# Object=%s Class=%s\n", $Object, $Class;
$Found = 1 if $Object == $Excel;
});
print "# Count=$Count Found=$Found\n";
print "not " unless $Found;
printf "ok %d\n", ++$Test;
# 50. _NewEnum should normally be non-browseable
my $Exists = grep /^_NewEnum$/, keys %{$Excel->Worksheets};
print "# Exists=$Exists\n";
print "not " if $Exists;
printf "ok %d\n", ++$Test;
# 51. make _NewEnum visible
Excel->Option(_NewEnum => 1);
$Exists = grep /^_NewEnum$/, keys %{$Excel->Worksheets};
print "# Exists=$Exists\n";
print "not " unless $Exists;
printf "ok %d\n", ++$Test;
# 52. _NewEnum available as a method
@Sheets = @{$Excel->Worksheets->_NewEnum};
print "# $_->{Name}\n" foreach @Sheets;
print "not " unless @Sheets == 11 && grep $_->Name eq "My Sheet #1", @Sheets;
printf "ok %d\n", ++$Test;
# 53. _NewEnum available as a property
@Sheets = @{$Excel->Worksheets->{_NewEnum}};
print "not " unless @Sheets == 11 && grep $_->Name eq "My Sheet #1", @Sheets;
printf "ok %d\n", ++$Test;
# 54. Win32::OLE proxies are non-unique by default
my $Application = $Excel->Application;
my $Parent = $Excel->Parent;
printf "# Application=%d Parent=%d\n", $Application, $Parent;
print "not " if $Application == $Parent;
printf "ok %d\n", ++$Test;
# 55. Parent and Application property should now return the same object
Excel->Option(_Unique => 1);
$Application = $Excel->Application;
$Parent = $Excel->Parent;
printf "# Application=%d Parent=%d\n", $Application, $Parent;
print "not " unless $Application == $Parent;
printf "ok %d\n", ++$Test;
# 56. Determine Dispatch ID of "Parent"
my $dispid = $Excel->GetIDsOfNames("Parent");
print "# DispID=$dispid\n";
print "not " unless $dispid == 150;
printf "ok %d\n", ++$Test;
# 57. Dispatch using numeric ID instead of method/property name
$Parent = $Excel->Invoke($dispid);
printf "# Application=%d Parent=%d\n", $Application, $Parent;
print "not " unless $Application == $Parent;
printf "ok %d\n", ++$Test;
# 58. Terminate server instance ("ok $Test\n" printed by Excel destructor)
exit;