Leaked source code of windows server 2003
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

997 lines
27 KiB

# =========================================================================
# Name: UpdFX.pm
# Owner: RickKr
# Purpose: This module contains global variable assignments and support routines for UpdFX.pl
# History:
# 02/23/01, RickKr: Created.
# 03/08/01, RickKr: Don't show sd cmdline if return context is list.
# 03/30/01, RickKr: Moved sd functions to end of file.
# ============================================================================================
# Module definition
# Define package namespace for the module
package UpdFX;
# Export code required to execute at module load
BEGIN
{
# Use standard Exporter module functionality
use Exporter;
@ISA = qw(Exporter);
# List of all default exported variables and procedures
@EXPORT = qw
(
$TRUE
$FALSE
$DEFAULT
_Assert
_CopyFile
_DoesHelpArgExist
_EnsurePathExists
_Error
_GetDirList
_ParseArgs
_RequireArgument
_RequireReference
_SdExec
_SplitPath
_Warning
);
# Global constant declarations
$TRUE = (0 == 0);
$FALSE = (0 != 0);
$DEFAULT = undef;
}
# enum RefTypes
{
my $nEnum = 0;
$keRefNoRef = $nEnum++;
$keRefReference = $nEnum++;
$keRefScalar = $nEnum++;
$keRefArray = $nEnum++;
$keRefHash = $nEnum++;
$keRefCode = $nEnum++;
$keRefGlob = $nEnum++;
$keRefOLE = $nEnum++;
}
my %mhcRefTypes =
(
$keRefNoRef => "no reference",
$keRefReference => "REF",
$keRefScalar => "SCALAR",
$keRefArray => "ARRAY",
$keRefHash => "HASH",
$keRefCode => "CODE",
$keRefGlob => "GLOB",
$keRefOLE => "OLE",
);
use File::Copy;
# Module has successfully been initialized.
return ($TRUE);
# =========================================================================
# _Assert()
#
# Purpose:
# Print a standardized message and halt the system if an expression does not evaluate to true.
# Inputs:
# $bExpressionResult The boolean espression to evaluate.
# $sMsg A brief, informative message describing the test or failure (optional).
# Outputs:
# None.
# Dependencies:
# None.
# Notes:
# =========================================================================
sub _Assert
{
my ($bExpressionResult, $sMsg) = @_;
if (! $bExpressionResult)
{
UpdFX_Message("Assertion Failure", $sMsg);
exit(1);
}
}
# =========================================================================
# _Error()
#
# Purpose:
# Print a standardized error message.
# Inputs:
# $sMsg A brief, informative message describing failure (optional).
# Outputs:
# Returns $FALSE.
# Dependencies:
# None
# Notes:
# This routine should be called to signal errors that are serious, but do not prevent a script
# from continuing execution.
# ===========================================================================
sub _Error
{
my ($sMsg) = @_;
UpdFX_Message("Error", $sMsg);
return ($FALSE);
}
# =========================================================================
# _Warning()
#
# Purpose:
# Print a standardized warning message.
# Inputs:
# $sMsg A brief, informative message describing the warning (optional).
# Outputs:
# Returns $FALSE.
# Dependencies:
# None
# Notes:
# None.
# ===========================================================================
sub _Warning
{
my ($sMsg) = @_;
UpdFX_Message("Warning", $sMsg);
return ($FALSE);
}
# =========================================================================
# _GetCallStack()
#
# Purpose:
# Get the current call stack.
# Inputs:
# None.
# Outputs:
# The call stack as an array.
# Dependencies:
# None.
# Notes:
# None.
# =========================================================================
sub _GetCallStack
{
my $bContinue = $TRUE;
my $i = 0;
my $nIndex;
my $sPackage;
my $sFile;
my $nLine;
my $sSubName;
my $bHasArguments;
my $bWantArray;
my $sEvalText;
my $bIsRequire;
my $sNextFile;
my $nNextLine;
my @CallStack = ();
my $nStackIndex;
$nStackIndex = 0;
($sPackage, $sFile, $nLine, $sSubName, $bHasArguments, $bWantArray, $sEvalText, $bIsRequire) = caller($i++);
while ($bContinue)
{
$bContinue = ($sPackage, $sNextFile, $nNextLine, $sSubName, $bHasArguments, $bWantArray, $sEvalText, $bIsRequire) = caller($i++);
$CallStack[$nStackIndex] = $sFile;
if (defined($sSubName) && "(eval)" ne $sSubName)
{
$nIndex = index($sSubName, "::");
if (-1 != $nIndex)
{
$sSubName = substr($sSubName, $nIndex + 2);
}
if (0 != length($sSubName))
{
$CallStack[$nStackIndex] .= ":" . $sSubName;
}
}
$CallStack[$nStackIndex] .= "(" . $nLine . ")";
if (! $bContinue)
{
last;
}
$sFile = $sNextFile;
$nLine = $nNextLine;
$nStackIndex ++;
}
return (@CallStack);
}
# =========================================================================
# _DoesHelpArgExist()
#
# Purpose:
# Determine if the help arg is present in an arg list.
# Inputs:
# $rsaArgs List of args.
# Outputs:
# Returns $TRUE if help arg is present, else $FALSE.
# Dependencies:
# None.
# Notes:
# None.
# =========================================================================
sub _DoesHelpArgExist
{
my ($rsaArgs) = @_;
_RequireReference($rsaArgs, "\$rsaArgs", $keRefArray);
return (0 < grep(/^[\/-]?(\?|h|help)$/i, @$rsaArgs));
}
# =========================================================================
# _ParseArgs()
#
# Purpose:
# Use a list of valid args to parse a list of actual args into a hash.
# Inputs:
# $rhParsedArgs Reference to a hash that will receive the data.
# $rsaActualArgs Reference to an array containing the actual args.
# $rsaValidArgs Reference to an array containing valid args.
# $rsaRepeatedArgs Optional reference to an array listing the args
# (from valid args) that can be repeated.
# Outputs:
# Returns $TRUE for success, else $FALSE.
# Dependencies:
# None.
# Notes:
# None.
# =========================================================================
sub _ParseArgs
{
my ($rhParsedArgs, $rsaActualArgs, $rsaValidArgs, $rsaRepeatedArgs) = @_;
_RequireReference($rhParsedArgs, "\$rhParsedArgs", $keRefHash);
_RequireReference($rsaActualArgs, "\$rsaActualArgs", $keRefArray);
_RequireReference($rsaValidArgs, "\$rsaValidArgs", $keRefArray);
if (! defined($rsaRepeatedArgs))
{
$rsaRepeatedArgs = [];
}
foreach my $sArg (@$rsaActualArgs)
{
my $nStart = ($sArg =~ /^[\/-]/ ? 1 : 0);
my ($sArgName, $sArgValue) = split(/:/, lc(substr($sArg, $nStart)));
my $sFoundName;
my $sValidName;
# Check to see if the argument matches exactly an entry in the argument list
#
if (0 < grep(/^$sArgName$/i, @$rsaValidArgs))
{
$sFoundName = $sArgName;
}
# If the argument does not exactly match a valid arg in the list, then we check to see if
# we can match it to a portion of one (and only one) of the valid args.
#
else
{
foreach $sValidName (@$rsaValidArgs)
{
if ($sValidName =~ /^$sArgName/i)
{
if (defined($sFoundName))
{
return (_Error("Argument (" . $sArg . ") matches 2 possible args " .
"(/" . $sFoundName . ", /" . $sValidName . ")"));
}
$sFoundName = $sValidName;
}
}
}
# If we didn't find a match, return a nonfatal error
#
if (! defined($sFoundName))
{
return (_Error("Unknown argument specified (" . $sArg . ")"));
}
# If we did find a match, see if it can be repeated. If it can, add it to the array
# for this arg
#
if (grep(/$sFoundName/i, @$rsaRepeatedArgs))
{
push(@{$$rhParsedArgs{$sFoundName}}, $sArgValue);
}
# If it can't be repeated and doesn't already exist in the parsed args hash, add it
#
elsif (! exists($$rhParsedArgs{$sFoundName}))
{
$$rhParsedArgs{$sFoundName} = $sArgValue;
}
# We've already got the arg in parsed args, so we'll return a nonfatal error
# describing the problem
#
else
{
my $sFoundArgument = $$rhParsedArgs{$sFoundName};
if (lc($sFoundArgument) eq lc($sArgValue))
{
return (_Error("Duplicate argument detected (" . $sArg . ")"));
}
else
{
return (_Error("Redefined argument detected (/" . $sFoundName .
":" . $sFoundArgument . ", " . $sArg . ")"));
}
}
}
return ($TRUE);
}
# =========================================================================
# _IsReference()
#
# Purpose:
# Check to see is a variable is a reference.
# Inputs:
# $eRefType Reference type.
# $rVariable The variable to check.
# Outputs:
# Returns $TRUE if the passed variable is a reference of the indicated type, $FALSE otherwise.
# Dependencies:
# None.
# Notes:
# None.
# =========================================================================
sub _IsReference
{
my ($eRefType, $rVariable) = @_;
my $sRefType;
# Note: It is alright if $rVariable is undefined. Under that special case, the return value for
# ref will still be "", which is what we want to happen.
$sRefType = ref($rVariable);
if (defined($eRefType))
{
_Assert(defined($mhcRefTypes{$eRefType}), "Invalid Reference Type (\$eRefType) Passed.");
return ($mhcRefTypes{$eRefType} eq $sRefType);
}
# if $eRefType was passed as $DEFAULT, then we simply want to know if $rVariable is a reference
# but don't care what it references.
return ("" ne $sRefType);
}
# =========================================================================
# _RequireArgDefined()
#
# Purpose:
# Assert the existence of a required argument passed to an subroutine. Print a standardized
# text message if undefined.
# Inputs:
# $uArgument The argument to check.
# $sTextToDisplay The name of the argument to display to the user.
# Outputs:
# None.
# Dependencies:
# None.
# Notes:
# This routine is not exported to other modules.
# =========================================================================
sub _RequireArgDefined
{
my ($uArgument, $sTextToDisplay) = @_;
my @scExpectedRoutines = ("_RequireArgument", "_RequireReference");
if (defined($sTextToDisplay))
{
$sTextToDisplay .= " ";
}
else
{
$sTextToDisplay = "";
}
#
# Only process stack if there is going to be an error
#
if ( ! defined($uArgument))
{
my ($sPackage, $sFile, $sLine, $sSubName) = caller(1);
# If this sub is called from one of the expected arg handling routines, then we want to
# return information about the subroutine that called the expected routine and not information
# about the expected routine.
if (0 == grep(/$sSubName/, @scExpectedRoutines))
{
($sPackage, $sFile, $sLine, $sSubName) = caller(2);
}
#
# Use standard assert functionality
#
_Assert($FALSE, "Required argument " . $sTextToDisplay . "not passed to " . $sSubName .
"() in " . $sFile . " line " . $sLine . ".");
}
}
# =========================================================================
# _RequireArgument()
#
# Purpose:
# Assert the existence of a required argument passed to an subroutine.
# Inputs:
# $uArgument The argument to check.
# $sTextToDisplay The name of the argument to display to the user.
# Outputs:
# None.
# Dependencies:
# None.
# Notes:
# None.
# =========================================================================
sub _RequireArgument
{
my ($uArgument, $sTextToDisplay) = @_;
_RequireArgDefined($uArgument, $sTextToDisplay);
#
# Ensure that a reference was not passed
#
if (_IsReference($DEFAULT, $uArgument))
{
my ($sPackage, $sFile, $sLine, $sSubName) = caller(1);
if (defined($sTextToDisplay))
{
$sTextToDisplay .= " ";
}
else
{
$sTextToDisplay = "";
}
#
# Use standard assert functionality
#
_Assert($FALSE, "Variable " . $sTextToDisplay . "passed to " . $sSubName .
"() in " . $sFile . " line " . $sLine . " is unexpected reference.");
}
}
# =========================================================================
# _RequireReference()
#
# Purpose:
# Assert that a variable is a reference.
# Inputs:
# $rVariable The variable to check.
# $sTextToDisplay The name of the variable to display to the user.
# $eRefType Identifier .
# Outputs:
# None.
# Dependencies:
# None.
# Notes:
# None.
# =========================================================================
sub _RequireReference
{
my ($rVariable, $sTextToDisplay, $eRefType) = @_;
my $sRefType = "";
_RequireArgDefined($rVariable, $sTextToDisplay);
if ( ! _IsReference($eRefType, $rVariable))
{
my ($sPackage, $sFile, $sLine, $sSubName) = caller(1);
if (defined($eRefType))
{
$sRefType = $mhcRefTypes{$eRefType} . " ";
}
if (defined($sTextToDisplay))
{
$sTextToDisplay .= " ";
}
else
{
$sTextToDisplay = "";
}
#
# Use standard assert functionality
#
_Assert($FALSE, "Variable " . $sTextToDisplay . "passed to " . $sSubName .
"() in " . $sFile . " line " . $sLine . " is not a " . $sRefType . "reference");
}
}
# =========================================================================
# UpdFX_Message()
#
# Purpose:
# Print a message in a standard format
# Inputs:
# $sHeader The type of message
# $sMsg A brief, informative message describing the event.
# Outputs:
# None.
# Dependencies:
# None.
# Notes:
# This subroutine is not exported.
# =========================================================================
sub UpdFX_Message
{
my ($sHeader, $sMsg) = @_;
_RequireArgument($sHeader, "\$sHeader");
my $sPrefix = "*** " . $sHeader;
if (defined($sMsg))
{
$sPrefix .= ": ";
}
else
{
$sMsg = "";
}
my $nStart;
my $nLength;
my @sMessage;
foreach my $sMsgText (split(/\n/, $sMsg))
{
push(@sMessage, $sPrefix . $sMsgText);
if (-1 != ($nStart = index($sPrefix, $sHeader)))
{
$nLength = length($sPrefix) - $nStart;
substr($sPrefix, $nStart, $nLength, " " x $nLength);
}
}
my @scShortMessages = ("Warning", "Error");
if (0 == grep(/$sHeader/, @scShortMessages))
{
push(@sMessage, ("CALL STACK...", _GetCallStack()));
}
print(join("\n", ("", @sMessage, "", "")));
}
# ===========================================================================
# _GetDirList()
#
# Purpose:
# Return a list of filenames and directories in directory.
# Inputs:
# $sDirectory Directory name
# $bDirectoriesOnly TRUE if only subdirectories are to be returned.
# Outputs:
# List of directory entries.
# Dependencies:
# None
# Notes:
# ===========================================================================
sub _GetDirList
{
my ($sDirectory, $bDirectoriesOnly) = @_;
_RequireArgument($sDirectory, "Directory");
if ( ! defined($bDirectoriesOnly))
{
$bDirectoriesOnly = $FALSE;
}
my @sDirList;
if (! -d $sDirectory)
{
_Error("Directory not found (" . $sDirectory . ")");
}
else
{
if (! opendir(hDirectory, $sDirectory))
{
_Error("Cannot open directory (" . $sDirectory . ")");
}
else
{
# Strip out the . and .. directories
# ! / # do not match
# ^ # start of string
# \. # single period
# \.? # followed by optional period
# $ # end of string
# /
@sDirList = grep (!/^\.\.?$/, readdir(hDirectory));
closedir(hDirectory);
if ($bDirectoriesOnly)
{
@sDirList = grep(-d $sDirectory . "\\" . $_, @sDirList);
}
}
}
return (@sDirList);
}
# =========================================================================
# _SplitPath()
#
# Purpose:
# Separate path and drive from a fully or partly qualified path name
# Inputs:
# $sPath input path name
# Outputs:
# Returns an array:
# - drive (C:) or "" if not present
# - path (\foo\bar) or "" if not present
# - filename (blech.c) or "" if not present
# Notes:
# Example: "c:\directory\subdir\file.ext" will get split into
# ("c:", "\directory\subdir\", "file.ext")
#
# UNC paths are treated as the path part. I.E. "\\server\share\foo\bar.c"
# will get split into ("", "\\server\share\foo\", "bar.c")
#
# =========================================================================
sub _SplitPath
{
my ($sPath) = @_;
my $sDrivePart = "";
my $sPathPart = "";
my $sFilePart = "";
_RequireArgument($sPath, "\$sPath");
#
# /^ Start of string
# (.) Drive letter, assign to $1
# : Followed by a colon
# (.*) Rest of string, assign to $2
# /
if ($sPath =~ /^(.):(.*)/)
{
$sDrivePart = $1 . ":";
$sPath = $2;
}
#
# /^ Start of string
# (.+) any characters, as many as possible, assign to $1
# \\ Followed by backslash
# (.*) Rest of string, assign to $2
# /
if ($sPath =~ /^(.+)\\(.*)/)
{
$sPathPart = $1 . "\\";
$sPath = $2;
}
# what remains must be filename.
$sFilePart = $sPath;
return (($sDrivePart, $sPathPart, $sFilePart));
}
# =========================================================================
# _EnsurePathExists()
#
# Purpose:
# Make sure a full path (from the root) exists.
# Inputs:
# $sPath - The path you want to make sure exists
# Outputs:
# $TRUE if it exists, $FALSE if it can't create the path.
# Dependencies:
# None
# Notes:
# If the supplied path is simply a share (\\server\share) or a drive (c:),the
# function will return $FALSE.
# ===========================================================================
sub _EnsurePathExists
{
my($sPath) = @_;
my @sDirectoryList;
my $sDir;
@sDirectoryList = split /\\/, $sPath;
if ((1 < length($sDirectoryList[0])) && (":" eq substr($sDirectoryList[0], 1, 1)))
{
$sPath = $sDirectoryList[0];
shift(@sDirectoryList);
}
elsif ("\\\\" eq substr($sPath, 0, 2))
{
shift(@sDirectoryList);
shift(@sDirectoryList);
$sPath = "\\\\" . $sDirectoryList[0] . "\\" . $sDirectoryList[1];
shift(@sDirectoryList);
shift(@sDirectoryList);
}
else
{
$sPath = "";
}
#
# determine if an invalid path (x:, \\server\share) was passed.
#
if (! @sDirectoryList)
{
return ($FALSE);
}
foreach my $sDir (@sDirectoryList)
{
$sPath .= "\\$sDir";
if (! -d $sPath)
{
if (! mkdir($sPath, umask()))
{
# If we couldn't create the dir, it's possible that someone else either beat us to it or is in
# the process of creating that same dir. So we'll sleep for 10 seconds (to allow the other process
# to complete) and check for it's existence again
#
sleep(10);
if (! -d $sPath)
{
return (_Error("Cannot create required directory (" . $sPath . ")"));
}
}
}
}
return ($TRUE);
}
# =========================================================================
# _CopyFile()
#
# Purpose:
# Copy a file, creating the destination path if necessary
# Inputs:
# $sSrcFileSpec Filespec of the source file
# $sDestFileSpec Filespec of the destination file
# Outputs:
# Returns $TRUE for success, $FALSE for failure
# Dependencies:
# None
# Notes:
# =========================================================================
sub _CopyFile
{
my ($sSrcFileSpec, $sDestFileSpec) = @_;
_RequireArgument($sSrcFileSpec, "\$sSrcFileSpec");
_RequireArgument($sDestFileSpec, "\$sDestFileSpec");
my ($sDestDrive, $sDestPath, $sDestName) = _SplitPath($sDestFileSpec);
my $sDestPathSpec = $sDestDrive . $sDestPath;
if (_EnsurePathExists($sDestPathSpec)) # else error already output
{
if (0 == copy($sSrcFileSpec, $sDestFileSpec))
{
return (_Error("Cannot copy file (" . $sSrcFileSpec . ")--" . $!));
}
return ($TRUE);
}
return ($FALSE);
}
# =========================================================================
# _SdExec()
#
# Purpose:
# Change the current dir and run an SD command
# Inputs:
# $sCmd SD command to run (e.g. sync, edit, ...)
# $sFileSpec Filespec to run command on
# $bShowOnly (Optional) If $TRUE, only show command
# Outputs:
# - Scalar context: Returns $TRUE for success, $FALSE for failure
# - List context: Returns the output from the command
# Dependencies:
# - Sd.exe must be on the path
# Notes:
# =========================================================================
sub _SdExec
{
my ($sCmd, $sFileSpec, $bShowOnly) = @_;
_RequireArgument($sCmd, "\$sCmd");
_RequireArgument($sFileSpec, "\$sFileSpec");
my ($sFileDrive, $sFilePath, $sFileName) = _SplitPath($sFileSpec);
my $sPathSpec = $sFileDrive . $sFilePath;
if (! _EnsurePathExists($sPathSpec))
{
return (_Error("Cannot create path (" . $sPathSpec . ")"));
}
if (! chdir($sPathSpec))
{
return (_Error("Cannot set path (" . $sPathSpec . ")"));
}
my @sSdArgs = (lc($sCmd));
my %hcSdArgs = ("opened" => "-l");
if ($hcSdArgs{$sSdArgs[0]})
{
push(@sSdArgs, $hcSdArgs{$sSdArgs[0]});
}
my $sSdNum = UpdFX_GetSdChangeListNumber($sCmd, $sPathSpec);
if (defined($sSdNum))
{
push(@sSdArgs, "-c " . $sSdNum);
}
my $sSdArgs = join(" ", @sSdArgs);
my $sSdCmd = "sd.exe";
if ($bShowOnly)
{
$sSdCmd = "echo " . $sSdCmd;
}
elsif (! wantarray())
{
print("sd " . $sSdArgs . " " . $sFileSpec . "\n");
}
if ("submit" ne $sSdArgs[0])
{
$sSdArgs .= " " . $sFileName;
}
if (wantarray())
{
return (`$sSdCmd $sSdArgs`);
}
my $bSucceeded = (0 == system($sSdCmd . " " . $sSdArgs));
if (($bSucceeded) && ("revert" eq $sSdArgs[0]))
{
system($sSdCmd . " change -d " . $sSdNum);
}
return ($bSucceeded);
}
# =========================================================================
# UpdFX_GetSdChangeListNumber()
#
# Purpose:
# Get the changelist number associated with an SD command
# Inputs:
# $sCmd SD command to run (e.g. sync, edit, ...)
# $sPathSpec Path where command will be invoked
# Outputs:
# Returns a changelist number if needed for the cmd, else undefined
# Dependencies:
# - Sd.exe must be on the path
# Notes:
# - This routine is not exported--it is intended solely as a helper
# function for _SdExec()
# =========================================================================
{
my %hChangeListNumber = ();
sub UpdFX_GetSdChangeListNumber
{
my ($sCmd, $sPathSpec) = @_;
_RequireArgument($sCmd, "\$sCmd");
_RequireArgument($sPathSpec, "\$sPathSpec");
my @scChangeListCmds = ("add", "edit", "delete", "opened", "revert", "submit");
if (0 == grep(/$sCmd/i, @scChangeListCmds))
{
return (undef);
}
if (! defined($hChangeListNumber{$sPathSpec}))
{
my $sSdInfo = `sd.exe info`;
my ($sClientRoot) = ($sSdInfo =~ /Client root:\s*(.+)\s+/);
if (! defined($hChangeListNumber{$sClientRoot}))
{
my $scDescription = "NetFX Component Update";
my ($sUserName) = ($sSdInfo =~ /User name:\s*(.+)\s+/);
my ($sClientName) = ($sSdInfo =~ /Client name:\s*(.+)\s+/);
my $sPendingChangesCmd = "sd.exe changes -s pending -u " . $sUserName;
# new change will be created if there is no pending change on this client
my ($sPendingChange) = grep (/\@$sClientName .+$scDescription/, `$sPendingChangesCmd`);
if (! defined($sPendingChange))
{
my @sChangeListText = ();
foreach my $sLine (`sd.exe change -o`)
{
if ($sLine =~ /<enter description here>/)
{
push(@sChangeListText, "\t" . $scDescription);
last;
}
push(@sChangeListText, $sLine);
}
if (open(hProcess, "| sd.exe change -i"))
{
print(hProcess @sChangeListText);
close(hProcess);
}
($sPendingChange) = grep(/$scDescription/, `$sPendingChangesCmd`);
_Assert(defined($sPendingChange), "Cannot create changelist");
}
my ($sChangeNumber) = ($sPendingChange =~ /Change (\d+)/);
_Assert(defined($sChangeNumber), "Cannot find changelist number");
$hChangeListNumber{$sClientRoot} = $sChangeNumber;
}
$hChangeListNumber{$sPathSpec} = $hChangeListNumber{$sClientRoot};
}
return ($hChangeListNumber{$sPathSpec});
}
}