#
# This is an include file for perl scripts, providing a bunch of little
# utility functions.
# - anandg
#

$MWTECHNO = $ENV{"MWTECHNO"};
$MWHOME = $ENV{"MWHOME"};
$MWLIB = "$MWHOME/lib";
$MWBIN = "$MWHOME/bin";
$MWARCH_OS = $ENV{"MWARCH_OS"};
$MWARCH = $ENV{"MWARCH"};
$MWOS = $ENV{"MWOS"};
$MWCONFIG_NAME = $ENV{"MWCONFIG_NAME"};
$CCPP = $ENV{"CCPP"};
$CC = $ENV{"CC"};
$MWCCPP = $ENV{"MWCCPP"};
$MWCC = $ENV{"MWCC"};
$MWEXE_INSTRUMENT = $ENV{MWEXE_INSTRUMENT};
$MWTOOL_TRACE = $ENV{MWTOOL_TRACE};
$DLL_SUFFIX = $ENV{DLL_SUFFIX};
$ENV_INCLUDE = "INCLUDE";
$INCLUDE = $ENV{$ENV_INCLUDE};
$ENV_MWINCLUDE = "MWINCLUDE";
$MWINCLUDE = $ENV{$ENV_MWINCLUDE};

($ld_lib_path_name, $lib_suffix) = &lib_path_and_suffix ($MWOS);
@ld_lib_path = fullsplit (":+", $ENV{$ld_lib_path_name});
@ld_link_path = build_link_path ();

sub print_error
{
    my ($status, @message) = (shift, @_);
    print "## Error: @message\n";
    # the only legal exit values of Perl are 0 and 1, other values may
    # cause problems in some platforms.
    exit(0) if ($status == 0);
    exit(1);
}

## Note that split may create an emptr first element. fullsplit pops this
## element if necessary.
sub fullsplit
{
    my ($pat, $str) = @_;
    if ( not defined $str) {
	return ();
    }
    my @l = split ($pat, $str);
    shift (@l) if (! $l [0]);
    return @l;
}

sub swap {
    local (*first, *second) = (shift, shift);
    $tmp = $first;
    $first = $second;
    $second = $tmp;
}

sub perl_exec {
    local ($arg, $command);
    $command = "$MWBIN-${MWARCH_OS}/mwperl";
    foreach $arg (@_) {
	$command = "$command $arg";
    }
    system ($command);
}

sub lib_path_and_suffix {
    local ($os_type) = shift;
    local ($path_name) = "LD_LIBRARY_PATH";
    local ($suffix) = $ENV{DLL_SUFFIX};
    if ($os_type =~ /^ux[0-9]/) {
	$path_name = "SHLIB_PATH";
    }
    elsif ($os_type =~ /^aix[0-9]/) {
	$path_name = "LIBPATH";
    }
    return ($path_name, $suffix);
}

# This routine builds the list of directories that scripts performing
# linker like duties use for searches. This is used (for instance) in 'mwdip'.
# The list if built using '@ld_lib_path' and the env var LD_ARCHIVE_PATH
sub build_link_path {
    my @list;
    @list = fullsplit (":+", $ENV{"LD_ARCHIVE_PATH"});
    my $dir;
    foreach $dir (@ld_lib_path) {
	push (@list, $dir) unless (($MWOS eq "irix6") && ($dir =~ /mips[0-9]/));
    }
    return @list;
}

sub nice_print {
    local ($x) = join (" ", @_);
    print "$x\n";
}

# Print message to stderr
sub Error {
    local($msg) = shift;

    print STDERR "\nERROR:** $msg.\n\n";
}

# Print message to stderr
sub FatalError {
    local($msg) = shift;
    local($exitcode) = shift;

    print STDERR "\nFATAL ERROR:** $msg.\nexiting ...\n\n";
    exit 1;
}

# Chdir with error checking and exits on failure
sub SafeChdir {
    local($dir) = shift;

    if ( -d $dir ) {
	chdir($dir) || &FatalError("Changing directory to '$dir'", -1);
    } else {
	&FatalError("Invalid directory '$dir'", -1);
    }
}

# Returns status code of program executed on success, exits on failure
sub ExecuteCommand {
    local(@command) = @_;
    # remove empty params from command
    local @new_cmd = grep($_, @command);
    local($stat) = system(@new_cmd);
    local($exitcode);

    $exitcode = $stat / 256;
    if ($exitcode != 0) {
	&FatalError("Command: '$command[0]' failed/aborted", $exitcode);
    }
    return $stat;
}

# Same as ExecuteCommand, doesn't print error message
sub SilentExecuteCommand {
    local(@command) = @_;
    # remove empty params from command
    local @new_cmd = grep($_, @command);
    local($stat) = system(@new_cmd);
    local($exitcode);

    $exitcode = $stat / 256;
    exit (1) if ($exitcode != 0);
    return $stat;
}

# Same as ExecuteCommand, but does not exit on failure
sub ExecuteCommandNoExit {
    local(@command) = @_;
    # remove empty params from command
    local @new_cmd = grep($_, @command);
    local($stat) = system(@new_cmd);
    local($exitcode) = $stat / 256;

    if ($exitcode != 0) {
	&Error("Command: '$command[0]' failed/aborted");
    }
    return $stat;
}

# Print the command line and execute it as well
sub ShowAndExecuteCommand {
    local(@command) = @_;
    {
	local $^W = 0; # @command may contain undefs
	print("COMMAND: @command \n");
    }
    return &ExecuteCommand(@command);
}

# Same as ShowAndExecuteCommand, but does not exit on failure
sub ShowAndExecuteCommandNoExit {
    local(@command) = @_;

    print("COMMAND: @command \n");
    return &ExecuteCommandNoExit(@command);
}


# Returns 1 if user chooses yes|TES|y|Y else returns 0
sub IsYes {
    local($msg) = pop(@_);
    local($resp);

    $resp  = &GetString("$msg (yes or no) ?");
    if (($resp eq "yes")||($resp eq "YES") ||($resp eq "y")||($resp eq "Y")) {
        return 1;
    }
    return 0;
}

# Exits if the users does not choose Yes
sub ExitOnNo {
    local($msg) = pop(@_);

    if (!&IsYes($msg)) {
	print("Exiting ...\n");
	exit(1);
    }
}

# Prompt user for a string and return it
sub GetString {
    local($message) = pop(@_);
    local($response);

    while (1) {
        print("$message: ");
        $response = scalar(<STDIN>);
        chop($response);
        if ($response ne "") {
            return $response;
	}
    }
}

# GetString with a default return value if the user just hits CR
sub GetStringDefault {
    local($default) = pop(@_);
    local($message) = pop(@_);
    local($response);

    printf("$message: ");
    $response = scalar(<STDIN>);
    chop($response);
    if ($response eq "") {
	return $default;
    } else {
	return $response;
    }
}

# A version og GetString that makes sure that the string is in fact a directory
sub GetDirectory {
    local($message) = pop(@_);
    local($response);

    while (1) {
        printf("$message: ");
        $response = scalar(<STDIN>);
        chop($response);
        if ( -d $response ) {
            return $response;
	} else {
	    printf("Invalid directory '$response'\n");
	}
    }
}

# GetDirectory with a default value
sub GetDirectoryDefault {
    local($default) = pop(@_);
    local($message) = pop(@_);
    local($response);

    while (1) {
	printf("$message: ");
	$response = scalar(<STDIN>);
	chop($response);
	if ($response eq "") {
	    return $default;
	}
        if ( -d $response ) {
            return $response;
	} else {
	    printf("Invalid directory '$response'\n");
	}	    
    }
}

#
# MwCleanupPath - Cleanup a pathname, much the same as the mainwin library function.
#	This is incomplete in that it does not remove "/name/../" sequences from
#	the path string.
#
sub MwCleanupPath {
    local($p) = shift;

    $p =~ s@//@/@g;
    $p =~ s@/\./@/@g;

    return $p;
}

# Just print a line of "-"
sub PrintLine {
    print "-----------------------------------------------------------------------------\n\n";
}

# A simple banner helper
sub Banner {
    local($string) = pop(@_);

    &PrintLine();
    print "$string ...\n";
    &PrintLine();
}


################## MwSearchPath implementation in perl



$dircount = 0;
sub dirhandle {
    return "DIR" . $dircount++;
}

#
# look_for_file($path, $file) - Look within the directory named in $path
# for $file, caselessly.
#
sub look_for_file {

    #print "look_for_file path: '$_[0]' file: '$_[1]'\n";

    my ($pat, $trial);
    ($pat = $_[1]) =~ tr/A-Z/a-z/;

    opendir(DIR, $_[0]);
    foreach (readdir(DIR)) {

	next if /^\.$/o || /^\.\.$/o;

	($trial = $_) =~ tr/A-Z/a-z/;
	if ($pat eq $trial) {
	    next if -d $_;
	    closedir(DIR);
	    return &MwCleanupPath($_[0] . "/" . $_);
	}
    }
    closedir(DIR);
    return "";
}

#
# look_for_dir($current_path, $rest_of_path, $file) - Recurse beginning
#	at $current_path looking for director{y,ies} which match
#	what's specified in $rest_of_path.  Once a matching directory
#	has been found call &look_for_file to see if $file is there.
#	All matches for path components are caseless.
#
# This function is recursive and due to some braindeadness in perl4
# the recursion is needlessly complex.  One should be able to say 'local($var)'
# and have, as expected, the $var be local to this stack frame only.
# HOWEVER what 'local' does is make the variable non-global, the variable
# is STILL visible from the child stack frames which means that it is the
# same temporary variable at all stack frames.  When the child invocation
# of &look_for_dir stores a value in a variable, it is actually stored in
# the version created in the top stack frame of the invocations of &look_for_dir.
#
# That is, say you have "local($a); ... $a = '123';", then recursively call
# the same function.  When the child invocation assigns a value to $a the
# assignment is made to the copy created by the parent invocation.
#
# The nicest way out of this is to push values onto array variables,
# using the arrays as a stack.
#
# Each level of the recursion, then, stores its value for the temporary
# variables at @stackname[$#stackname] (the top of the stack).  It pushes
# the value it wants at the beginning of the function with push(@stackname, $value).
# Then all retrieves the value with @stackname[$#stackname].  And when it
# returns it takes care to pop off the value with pop @stackname.
#
sub look_for_dir {

    #
    # Save the arguments to this function invocation.
    #
    push(@curpathstack,  $_[0]);
    push(@restpathstack, $_[1]);
    push(@filestack,     $_[2]);

    # print "look_for_dir curpath: '@curpathstack[$#curpath]' restpath: '@restpathstack[$#restpath]' file: '@filestack[$#filestack]'\n";

    local($this_path_component, $rest_of_path, $t, $r, $thishand, $resthand, $ret, $rest, $this);

    #
    # Find the next path component to look for.
    #
    # We're stripping components off of $rest_of_path until there
    # are no more components, at which time we call &look_for_file
    # to recurse rather than &look_for_dir.
    #
    if ($_[1] =~ /\//o) {			# Directory component
	$_[1] =~ /^([^\/]*)\/(.*)$/o;		# Separate the dir/rest/of/path
	$this = $1;				# into dir
	$rest = $2;				# and rest/of/path
    }
    else {
	$this = $_[1];				# No more
	$rest = "";
    }

    push(@thistack, $this);			# Save these on a stack
    push(@restack,  $rest);

    #
    # Costruct a list of candidates for this component.
    #
    # Read through the directory ($current_path) looking,
    # caselessly, for matches to the next component.
    #

    ($t = $this) =~ tr/A-Z/a-z/;		# temp var for comparisons.

    $dh = &dirhandle;				# Store the component candidates
    						# in an uniquely named array.

    opendir(DIR, $curpathstack[$#curpathstack]);
    #print "POSSIBLES with $t: ";

    foreach (sort(readdir(DIR))) {
	next if /^\.$/o || /^\.\.$/o;		# Skip uninteresting things.

	($a = $_) =~ tr/A-Z/a-z/;
	if ($t eq $a) {				# And add to list if it matches.
	    next if ! -d $curpathstack[$#curpathstack] . "/" . $_;
	    eval "push(@$dh, \"$_\");";
	    # print $_, " ";
	}
    }
    # print "\n";
    closedir(DIR);

    #
    # Now that we have candidates try each one.
    #
    foreach (eval "@$dh") {

	#print "Trying @curpathstack[$#curpathstack]/$_; this: @thistack[$#thistack] ($#thistack), rest: @restack[$#restack] ($#restack)\n";

	# Need to recalculate $t each time because of recursion.
	($t = $thistack[$#thistack]) =~ tr/A-Z/a-z/;
	($u = $_) =~ tr/A-Z/a-z/;
	if ($u eq $t) {			# Matches?  If so, recursion is divine.
	    $r = $restack[$#restack];
	    if ($r eq "") {		# No more?  Look for the file instead.
		$ret = &look_for_file(&MwCleanupPath($curpathstack[$#curpathstack] . "/" . $_),
				      "$filestack[$#filestack]");
	    }
	    else {			# To iterate is human, to recurse divine.
		$ret = &look_for_dir(&MwCleanupPath($curpathstack[$#curpathstack] . "/" . $_),
				     "$restack[$#restack]",
				     "$filestack[$#filestack]");
	    }
	    if ($ret ne "") {		# If found then return what we found.
		# print "FOUND: $ret\n";
		pop @curpathstack;
		pop @restpathstack;
		pop @filestack;
		pop @thistack;
		pop @restack;

		return $ret;
	    }
	}
    }

    #
    # Nothing was found so return empty string to indicate that.
    #

    # print "NOPE:: curpath: '@curpathstack[$#curpath]' restpath: '@restpathstack[$#restpath]' file: '@filestack[$#filestack]'\n";
    pop @thistack;
    pop @restack;
    pop @curpathstack;
    pop @restpathstack;
    pop @filestack;
    return "";
}

#
# MwSearchPath - Look for a pathname caselessly.  Similar to the library function MwSearchPath.
#
#	USAGE: $found = &MwSearchPath($path, $file)
#
# The function looks for $file starting from the place specified
# in $path.  Each component of $path is examined in turn looking
# for whatever entries match it (caselessly; such that /usr/include/SYS/types.H
# will match as /usr/include/sys/types.h).  It recurses through the path
# and if multiple path components match, each will be tried.  The first
# match found will be returned.
#
# The core of the functionality is in &look_for_dir which does
# the recursive search for the directory, and &look_for_file which
# looks for the matching file once a candidate directory is found.
#
sub MwSearchPath {
    local($path) = &MwCleanupPath($_[0]);
    local($file) = &MwCleanupPath($_[1]);

    local($start, $ret);

    #print "\n\n\n**************** MwSearchPath $path $file\n";

    if ( -d $path ) {				# See if we can do this quickly.
	$ret = &look_for_file($path, $file);
	if ( $ret ne "" ) {
	    return $ret;
	}
    }


    if ($file =~ /\\/) {			# Translate any \'s to /'s.
	$file =~ tr/\\/\//;
    }

    #
    # If $file contains /'s then transfer the directory part
    # to $path.  This is so that &look_for_file does not
    # have to traverse any directory trees itself.
    #
    if ($file =~ /\//) {
	#print "file name '$file' contains /'s\n";
	$file =~ /^(.*)\/([^\/]*)$/;
	$path = $path . "/" . $1;
	$file = $2;
	#print "path: $path, file: $file\n";
    }

    #
    # Figure out the starting point for the search.
    #
    if ($path =~ /^\/.*$/) {
	#print "Rooted path $path\n";
	$start = "/";
	$path =~ s@/(.*)$@$1@;
    }
    else {
	#print "Relative path $path\n";
	$start = "./";
    }

    if ( -d $start . $path ) {				# See if we can do this quickly.
	$ret = &look_for_file($start . $path, $file);
	if ( $ret ne "" ) {
	    return $ret;
	}
    }

    #print "About to call MwSearchPathRec '$start' '$file' '$path'\n";

    return &look_for_dir($start, $path, $file);
}

sub calc_safe_name {
    my ($orig_name) = @_;

    # build a hash of all legal characters
    my $a;
    my %is_legal;
    foreach $a ('a'..'z') {
	$is_legal{$a} = 1;
    }
    foreach $a ('A'..'Z') {
	$is_legal{$a} = 1;
    }

    my $temp_name = $orig_name;
    my $output_name = "";
    while ($temp_name ne "") {
	my $char = chop($temp_name);
	if (defined $is_legal{$char}) {
	    $output_name = $char . $output_name;
	} else {
	    my $str = sprintf "%02x", ord($char);
	    $output_name = "_" . $str . $output_name;
	}
    }
    return $output_name;
}



######################## End MwSearchPath implementation in perl



# Disable buffering on stdout
local($oldfh) = select(STDOUT); $| = 1; select($oldfh);

# Return a value. I dont understand why it is needed. But without this
# require statement does not succeed at the caller
2;

