PerlScript support

[eric.zarko]

Consider adding "PerlScript" as a listed ProgId for scripts and adding the following XML chunk to VisBuildPro.System.scripts.

<script>
<language>PerlScript</language>
<code><![CDATA[# Predefined Visual Build System scripts available to all build projects
use constant {
# AppCreateContextEnum
vbldContextAutomation => 0,
vbldContextGUI => 1,
vbldContextCommandLine => 2,
vbldContextCount => 3,

# BuildCompletionStatusEnum
vbldBuildCompDone => 0,
vbldBuildCompFailed => 1,
vbldBuildCompAborted => 2,
vbldBuildCompCount => 3,

# BuildLaunchTypeEnum
vbldLaunchBuild => 0,
vbldLaunchRebuild => 1,
vbldLaunchRebuildSel => 2,
vbldLaunchNone => 3,
vbldLaunchCount => 4,

# BuildStatusEnum
vbldBuildStatDone => 0,
vbldBuildStatStarted => 1,
vbldBuildStatPauseReq => 2,
vbldBuildStatPaused => 3,
vbldBuildStatAborting => 4,
vbldBuildStatCount => 5,

# ExpandMacroResultEnum
vbldExpandSuccess => 0,
vbldExpandParseError => 1,
vbldExpandRecurseLimit => 2,
vbldExpandUnknownMacro => 3,
vbldExpandValueError => 4,

# MacroFilterEnum
vbldMacroFilterEnvVar => 0,

# MacroTypeEnum
vbldMacroAll => -1,
vbldMacroTemporary => 0,
vbldMacroProject => 1,
vbldMacroGlobal => 2,
vbldMacroSystem => 3,
vbldMacroCount => 4,

# OutputLocEnum
vbldOutputNone => 0,
vbldOutputStdout => 1,
vbldOutputFile => 2,
vbldOutputCount => 3,

# ProjectStatusSaveOptionsEnum
vbldSaveStatusInclude => -1,
vbldSaveStatusExclude => 0,
vbldSaveStatusUseDefault => 1,

# RedirectInputEnum
vbldRedirInputNone => 0,
vbldRedirInputFile => 1,
vbldRedirInputString => 2,
vbldRedirInputCount => 3,

# RuleComparisonEnum
vbldRuleNone => -1,
vbldRuleUndefined => 0,
vbldRuleDefined => 1,
vbldRuleContains => 2,
vbldRuleEqual => 3,
vbldRuleNotEqual => 4,
vbldRuleDoesNotContain => 5,
vbldRuleTrue => 6,
vbldRuleCount => 7,

# ScriptTypeEnum
vbldScriptAll => -1,
vbldScriptTemporary => 0,
vbldScriptProject => 1,
vbldScriptGlobal => 2,
vbldScriptSystem => 3,
vbldScriptCount => 4,

# StepStatusEnum
vbldStepStatNone => -1,
vbldStepStatSucceeded => 0,
vbldStepStatFailed => 1,
vbldStepStatAborted => 2,
vbldStepStatSkipped => 3,
vbldStepStatInProgress => 4,
vbldStepStatMacroError => 5,
vbldStepStatPartial => 6,
vbldStepStatCount => 7,

# StepTypeEnum
vbldStepMain => 0,
vbldStepSubroutine => 1,
vbldStepFailure => 2,
vbldStepGlobalSubroutine => 3,
vbldStepCount => 4,

# UndefMacroTreatmentEnum
vbldUndefPrompt => 0,
vbldUndefEmpty => 1,
vbldUndefError => 2,
vbldUndefLeave => 3,

};

# return the collection of all defined macros
sub vbld_AllMacros()
{
return $Application->Macros(vbldMacroAll);
}

# returns the current Date in a format valid for use in file/folder names:
# YYYYMMDD
sub vbld_FormatDate()
{
my @dte = localtime();
return ($dte[5]+1900) .
vbld_PadLeft(($dte[4]+1), 2, '0') .
vbld_PadLeft($dte[3], 2, '0');
}

# returns the current date+time in a format valid for use in file/folder names:
# DYYYYMMDDTHHMMSS
sub vbld_FormatDateTime()
{
my @dte = localtime();
return 'D' . ($dte[5]+1900) .
vbld_PadLeft(($dte[4]+1), 2, '0') .
vbld_PadLeft($dte[3], 2, '0') . 'T' .
vbld_PadLeft($dte[2], 2, "0") .
vbld_PadLeft($dte[1], 2, "0") .
vbld_PadLeft($dte[0], 2, "0")
}

# pads a string on the left with the given character to the specified length
sub vbld_PadLeft($$$)
{
my($str, $newLen, $padChar) = @_;
$str = $padChar . $str
while (length($str) < $newLen);
return $str;
}

# creates and returns a new FileSystemObject
sub vbld_FSO()
{
return Win32::OLE->new('Scripting.FileSystemObject');
}

# Copies a file
sub vbld_CopyFile($$$)
{
my($SourceFile, $DestFile, $Overwrite) = @_;
# ensure that the target file is not read-only
vbld_MakeFileWriteable($DestFile)
if ($Overwrite);
# copy
vbld_FSO()->GetFile($SourceFile)->Copy($DestFile, $Overwrite);
}

# Returns the modificiation date of a file
sub vbld_FileDateModified($;$) # note added second optional argument
{
my($FileSpec,$Type) = @_;
my $d = vbld_FSO()->GetFile($FileSpec)->DateLastModified();

# if they want a string
if (!defined($Type) && !wantarray)
{
# let's return it in the same format as VBScript and JScript
return $d->Date().' '.$d->Time();
}

my @d = split / /, $d->Time("s m H ").$d->Date("d M yyyy");
$d[4] -= 1;
$d[5] -= 1900;

use Time::Local;
$d = timelocal(@d);
return $d if ($Type eq 'raw'); # give them seconds since the epoch
return localtime($d); # call localtime for them (it respects wantarray)
}

# Ensure that a file is writeable and return True if found and succeeded
sub vbld_MakeFileWriteable($)
{
my($Filename) = @_;
if (vbld_FSO()->FileExists($Filename))
{
my $f = vbld_FSO()->GetFile($Filename);
$f->{Attributes} -= 1
if ($f->{Attributes} & 1);
# return true as long as the file was found
return 1;
}
return;
}

# Provides a simple 'make' capability to compare a source and target file
# compare the date/timestamp of two files and return -1 if the
# target file does not exist or is older than the source file,
# 0 if they are equal, or 1 if the target file is newer than the source file
sub vbld_CompareFileDates($$)
{
my($TargetFile, $SourceFile) = @_;
if (!vbld_FSO()->FileExists($TargetFile))
{
# file is out of date if target does not exist
return -1;
}
else
{
# if target is older than source, target out of date
return vbld_FileDateModified($SourceFile,'raw') <=> vbld_FileDateModified($TargetFile,'raw');
}
}

# Compares files by version info if available or size+timestamp if not
# if the target file does not exist, returns True;
# otherwise if the files contain version information, the
# version info is compared and True is returned if the target
# file's version is older;
# if no version info is available, the files are compared by timestamp
# of last modification, returning True if the target file is older;
# if the timestamps match, a file size comparison is also performed
# and True returned if target file is older than the source file
sub vbld_FileOutOfDate($$)
{
my($TargetFile, $SourceFile) = @_;
my $fso = vbld_FSO();
if (!($fso->FileExists($TargetFile)))
{
# file is out of date if target does not exist
return 1;
}
else
{
my $strTargVer = $fso->GetFileVersion($TargetFile);
my $strSrcVer = $fso->GetFileVersion($SourceFile);

# if version info is available, compare versions
if (length($strTargVer) > 0 && length($strSrcVer) > 0)
{
my @arrTargVer = split /\./, $strTargVer;
my @arrSrcVer = split /\./, $strSrcVer;

# compare each element individually, starting with major
# if target's is greater, not out of Date; if target's
# is less, out of date; if equal, compare the next value
for (my $i = 0; $i < @arrTargVer; $i++)
{
if ($arrTargVer[$i] > $arrSrcVer[$i])
{
return undef;
}
elsif ($arrTargVer[$i] < $arrSrcVer[$i])
{
return 1;
}
}
}
else
{ # if version info not available, use timestamp comparison
# if target is older than source, target out of date
return vbld_CompareFileDates($TargetFile, $SourceFile) < 0;
}
}
return undef;
}

...


************************************************** ********************
The views and opinions expressed in this message are those of the author. The contents of this message have not been reviewed or approved by Intel.
************************************************** ********************

[eric.zarko]

# create a new temporary macro with the value or add a string to end of the given
# temporary macro, separating each string with Tab char delimiter, and return the updated value
sub vbld_AddDelimValue($$)
{
my($macroName, $val) = @_;
my $macros = $Application->Macros(vbldMacroTemporary);
my $macro = $macros->Item($macroName);
if (!defined($macro)) # create initial value if it doesn't exist
{
$macro = $macros->Add($macroName, $val);
}
else # add delimiter and value if already exists
{
$macro->{Value} .= "\t" . $val;
}
return $macro->Value();
}

# given the name of a macro containing delimited strings (populated via
# vbld_AddDelimValue), remove the *first* delimited string from the value
# and return or return Null if the macro does not exist
sub vbld_NextDelimValue($)
{
my($macroName) = @_;
my $macros = $Application->Macros(vbldMacroTemporary);
my $val = undef;
{
my $macro = $macros->Item($macroName);
$val = $macro->Value()
if (defined($macro));
}
return undef
if (!defined($val)); # macro doesn't exist, return null

my $ret;
my $pos = index($val, "\t"); # find next delimiter
if ($pos < 0) # if no more delimiters, return the remaining value
{
$ret = $val;
$macros->Remove($macroName); # and delete the macro
}
else
{
$ret = substr($val, 0, $pos); # retrieve the next value
$macros->Add($macroName, substr($val, $pos+1)); # and remove from the macro
}
return $ret;
}

# alternate name for adding delimited value to end of a macro
sub vbld_PushDelimValue($$)
{
my($macroName, $value) = @_;
return vbld_AddDelimValue($macroName, $value);
}

# given the name of a macro containing delimited strings (populated via
# vbld_AddDelimValue), remove the *last* delimited string from the value
# and return or return Null if the macro does not exist
sub vbld_PopDelimValue($)
{
my($macroName) = @_;
my $macros = $Application->Macros(vbldMacroTemporary);
my $val = undef;
{
my $macro = $macros->Item($macroName);
$val = $macro->Value()
if (defined($macro));
}
return undef
if (!defined($val)); # macro doesn't exist, return null

my $ret;
my $pos = rindex($val, "\t"); # find last delimiter
if ($pos < 0) # if no more delimiters, return the remaining value
{
$ret = $val;
$macros->Remove($macroName); # and delete the macro
}
else
{
$ret = substr($val, $pos+1); # retrieve last delimited value
$macros->Add($macroName, substr($val, 0, $pos));# and remove from the macro
}
return $ret;
}
]]></code>
</script>

************************************************** ********************
The views and opinions expressed in this message are those of the author. The contents of this message have not been reviewed or approved by Intel.
************************************************** ********************

[eric.zarko]

Thanks for a great response in getting this added to 5.1 guys. Unf. you've got a few bugs.

First of all there are some typos in vbld_FileDateModified that break it completely.
614: "time" s/b "Time"
617: "time" s/b "Time", in date format need "M" not "m"
621: "time::local" s/b "Time::Local"

Second, you have 2 copies of vbld_AddDelimValue. The second should just override the first without really causing a problem, but it could cause maintenance issues for you in the future.

Finally, just a note on style. On lines 635 and 799(781 if you deal with #2 first) you have trailing "if" modifiers. It is not required but generally considered good style to add an extra prefix tab to make these really obvious.

************************************************** *********************
The views and opinions expressed in this message are those of the author. The contents of this message have not been reviewed or approved by Intel.
************************************************** *********************

[kinook]

Argh. The editor so helpfully lowercased those strings when they were pasted in (you'll probably want to disable the 'Fixup text case' option in the script editor right-click options dialog when editing PerlScript). The download has been updated with a fix for the typos (except that I couldn't see any formatting difference in the last two lines you mentioned).

[eric.zarko]

Originally posted by kinook
Argh. The editor so helpfully lowercased those strings when they were pasted in (you'll probably want to disable the 'Fixup text case' option in the script editor right-click options dialog when editing PerlScript). The download has been updated with a fix for the typos (except that I couldn't see any formatting difference in the last two lines you mentioned).

I understand how finicky editors can be. I will watch out for it in the future.
As for the formatting difference, the issue is that in C/C++, Java, etc you can do this:

if(x < 1)
  x = 1;

In perl if you use this syntax you are required to use braces, like so:

if($x < 1)
{
  $x = 1;
}

In order to allow terser code they allow the modifier ... this is an if, while, etc conditional at the end of a statement, like so:

$x = 1 if($x < 1);

So, in order to emphasise this, if you break between the statement and the modifier you indent the modifer an extra level, like so:

$x = 1
  if($x < 1);

It is really minor since whitespace is free, so I wouldn't push another version just because of this. Incidentally this is done this way on lines 599, 743, 746 and 784.