#
#	utils.pl - utility routines developed for SoftList 3.0
#
#	Daniel Smith, 1992
#
#	Routines in this file are not specific to SoftList


#	load_routine - load routines from files on the fly, and execute them
sub load_routine {
    local ($routine);
    
    $routine = $_[1];
    require $DIRS{'LIB'}."/$_[0]";
    if (defined $_[2]) {	# pass an arg
	&$routine($_[2]);
    } else {
	&$routine;
    }
}

#	call - set up a reference into %cmds
#
#	this is just a syntatic wrapper to make some aliases look better
sub call {
    $arg = $_[1];
    eval $cmds{$_[0]};
}

#	file_prompt
sub file_prompt {
    print TTYOUT "\n\n";
    @command_history = @filename_history;
    &get_input("\tenter filename");
    @filename_history = @command_history;
    return 1;
}


#	file_str_prompt - use the arg as prompt...
sub file_str_prompt {
    local($our_prompt) = @_;
    print TTYOUT "\n\n";
    @command_history = @filename_history;
    &get_input($our_prompt);
    @filename_history = @command_history;
    return 1;
}


#	quick_shell - push a bourne shell
sub quick_shell {
    &cbreak_off;
    system "/bin/sh";
    &cbreak_on;
}


#	sh - run a shell command

#	all kinds of room for improvement here...
sub sh {
    print TTYOUT "\n";
    &cbreak_off;
    $found_pipe = 0;
    foreach (@_) {
	(/.*\|.*/) && $found_pipe++;
    }
    
    # try to handle pipes...
    if ($found_pipe > 0) {
	open (SH_CMD, "| @_");
	while (<SH_CMD>) {
	    print TTYOUT;
	}
	close (SH_CMD);
    } else {
	system (@_);
    }
    &cbreak_on;
}


#	sh_record - run shell command and store output
# not working yet...

sub sh_record {
	&cbreak_off;
	open (SH_CMD, "@_ |") || warn "can't open @_\n";

	while (<SH_CMD>) {
		print TTYOUT "$_ $_\n";
		$sh_recording .= $_;
	}
	close (SH_CMD);
	&cbreak_on;
}
	
	

#	crc - generate checksum
#
#	not much use for this at the moment, although I did write an
#	alias (crc16) to call it.  Keep it around for SoftList, may be of use.
sub crc {
        open (THE_FILE, "< @_") || warn "can't open @_\n";
        $save_line_mode = $/;
        undef $/;
        $checksum = unpack("%16C*", <THE_FILE>);
        $/ = $save_line_mode;
}


#	these next two routines should probably be replaced by portable
#	perl equivalents
sub cbreak_on {
	if ($BSD) {
	    system "stty -echo cbreak </dev/tty >/dev/tty 2>&1";
	}
	else {
	    system "stty", 'cbreak',
	    system "stty", 'eol', '^A';
	}
}

sub cbreak_off {
    if ($BSD) {
	system "stty -cbreak echo </dev/tty >/dev/tty 2>&1";
    }
    else {
	system "stty", 'icanon';
	system "stty", 'eol', '^@';
    }
    print TTYOUT "\n";
}


#	flush - flush output
sub flush {
	$| = 1;
	print TTYOUT '';
	$| = 0;
}



#	center - center a string
#
#	yep, I assume 80 columns...
sub center {
	return sprintf("%s%s", ' ' x ((80 - length(@_[0])) / 2), @_[0]);
}

#	push_previous_menu
sub push_previous_menu {
	eval $last_used;
	return 1;
}


#	pop_level - go back a menu level
sub pop_level {
	if ($#menu_stack > 0) {
		$last_used = pop (@menu_stack);
	}
	1;
}


#	cd - a chdir which updates $ENV{'PWD'}
#
#	cd turned out to be more of a challenge than pushd and popd!  What
#	messed with my head was the varargs situation...the case of "cd"
#	by itself resolving to home, versus "cd somedir".  I'm punting.
#	from this point forward, cd will *always* modify @main_dir_stack,
#	and will always take one argument as its target.  Simplifies things
#	a lot here, and it's trivial to make an alias check for the $HOME case.
#	Mon Dec 30 23:55:47 PST 1991
sub cd {
	local ($cd_target) = @_;
	local ($ret) = 0;

	if (&chdir_cdpath ($cd_target)) {
		$ret++;
	}
	$ENV{'PWD'} = &fastcwd;
	$main_dir_stack[$#main_dir_stack] = $ENV{'PWD'};
	&set_dir_prompt;
	$ret;
}


#	set_dir_prompt - construct prompt for CLI
sub set_dir_prompt {
	local ($push_level_prompt) = '';
	if ($#main_dir_stack) {
		$push_level_prompt = " ($#main_dir_stack) ";
	}
	$dir_prompt = $ENV{'PWD'}.$push_level_prompt;
	1;
}


#	chdir_cdpath - do a chdir with the aid of $cdpath
sub chdir_cdpath {
	local ($target) = @_;
	local ($found) = 0;
	local ($i) = 0;

	if (! defined (@cdpath)) {
		@cdpath = ('.', '..', '../..');	# minimal @cdpath
	}

	# check for variables to expand...
	# Sun Jan 19 19:57:22 PST 1992
	if ($target =~ /^\$/) {
		$target = eval $target;
	}

	# check for an absolute pathname
	if ($target =~ /^\//) {
		if (-d $target) { # give it a shot, else we drop into the loop
			chdir ($target) && $found++;
		}
	}

	while ($found == 0 && $i < $#cdpath) {
		if (-d $cdpath[$i].'/'.$target) {
			chdir ($cdpath[$i].'/'.$target) && $found++;
		} else {
			$i++;
		}
	}
	$found;
}



#	pushd - pushd one or more directories onto a given stack
#
#	this routine must be called as:
#	&pushd(*some_menu_stack, *pushd_targets)
sub pushd {
	local (*which_stack, *pushd_targets) = @_;
	local ($i);

	if ($#pushd_targets == -1) {	# then we have a simple stack flip
		if ($#which_stack >= 1) { # then we have something to work with
			@old_top = pop (@which_stack);
			@new_top = pop (@which_stack);
			if (&chdir_cdpath ($new_top[0])){ 
				$ENV{'PWD'} = &fastcwd;
				push (@which_stack, @old_top);
				push (@which_stack, $ENV{'PWD'});
			} else { # a directory has disappeared out
				 # from under us..
				push (@which_stack, @new_top);
				push (@which_stack, @old_top);
			}
		}
	} else {
		foreach $push_arg (@pushd_targets) {
			if (&chdir_cdpath ($push_arg)) {
				$ENV{'PWD'} = &fastcwd;
				push(@which_stack, $ENV{'PWD'});
			} else {
			;
			# well? what? I can't just spit out "No such directory"
			# if this is being called internally...perhaps setting
			# the return value and leaving it up to whoever called
			# us to make the decision...
			}
		}
	}
	&set_dir_prompt;
	1;	# for now, this may change...
}


#	popd - pop directory from given stack
#
#       this routine must be called as:
#       &popd(*some_menu_stack)
#
sub popd {
    local (*which_stack) = @_;
    
    if ($#which_stack >= 1) {
	@old_top = pop (@which_stack);
	if (&chdir_cdpath ($which_stack[$#which_stack])) {
	    $ENV{'PWD'} = &fastcwd;
	    $which_stack[$#which_stack] = $ENV{'PWD'}; # dot our i's
	} else { # a directory has disappeared out from under us..
	    push (@which_stack, @old_top);
	}
    }
    &set_dir_prompt;
    1;
}


#	dirs - show current directory stack
sub dirs {
    local (*which_stack) = @_;
    local ($count) = 1;
    
    print TTYOUT "\n";
    foreach (reverse @which_stack) {
	print TTYOUT $count++."\t$_\n";
    }
    1;
}

#	basename - deletes any prefix ending in /
sub basename {
    local($basename, $suffix) = @_;

    if ($basename eq "/") {	# silly special case
	return("");
    }
    $basename  =~ s|.*/([^/]+)$|\1|o;
    if ($suffix !~ "") {
	$basename =~ s/$suffix$//;
    }
    return($basename);
}

#    file_prefix - return prefix of filename
sub file_prefix {
    local($filename) = @_;

    ($filename, $ignore) = split(/\./, &basename($filename));
    return $filename;
}

sub extension {
    local($pathname) = @_;

    @components = split(/\./, $pathname);

    if ($#components > 0) {
	return(".$components[$#components]");
    } else {
	return("");
    }
}


sub assure_set {
    local(*var, $default) = @_;

    if ($var =~ /^$/) {
	$var = $default;
    }
    1;
}

#	dirname - return leading directory path
sub dirname {
    local($pathname) = @_;

    if ($pathname =~ /^\/$/) {	# silly special case
	return("/");
    }
    if ($pathname =~ /^$/) { return("."); }
	@components = split('/', $pathname);
	if ($#components > 1) {
		pop(@components);
		return join('/', @components);
	} elsif ($#components == 1) {
		return("/");
	} else {
		return(".");
	}
}


#	set_alias - show all, show one, or set one
sub set_alias {
	local(@numal) = keys %aliases;
	if ($#_ == 0) {
		unless (open (PAGER, "| $ENV{'PAGER'}")) {
			warn "can't set up pager!: !$\n";
			return 1;
		}
		print PAGER <<"+++";

	There are $#numal aliases currently known.  You can use the "rc" alias
to update the ~/.SoftListrc file.

+++
		foreach (sort keys %aliases) {
			print PAGER "$_\t$aliases{$_}\n\n";
		}
		close PAGER;
	} elsif ($#_ == 1) {
		print TTYOUT "\n";
		print TTYOUT "@_[1]\t$aliases{@_[1]}\n";
	} else {
		$aliases{@_[1]} = "@_[2..$#_]"; # line noise, means 2'nd..end
	}
	1;
}


#	set_sh_alias - shortcut for setting shell aliases from ~/.SoftListrc
sub set_sh_alias {
	$aliases{@_[1]} = '&sh(@alias_args)';
	1;
}


#	do_fork - a generic fork routine
#
#	This should look familiar.  It's almost verbatim from the Camel Book.
#
#	pass in what routine the child should run, and then what
#	routine to signal in the parent.  The third parameter is what
#	signal the child should send to the parent.  So far it looks
#	like "QUIT" will work, but "CHLD" and "TERM" aren't any good.

#	BUG: kids are leaving behind zombie processes, what am I doing wrong?
#	do I need to do things the way they're shown on page 212?
sub do_fork {
	local ($child_routine, $parent_routine, $which_signal) = @_;
			$| = 1;

	# once we're done, signal parent here.
	$SIG{"$which_signal"} = $parent_routine;

FORK:	 {
		if ($pid = fork) {
			# parent here
			# child process pid is available in $pid
			1;

		} elsif (defined $pid) { # $pid is zero here if defined

			# child here
			# parent process pid is available with getppid
			eval $child_routine;
			kill 'QUIT', getppid;
			exit 1;

		} elsif ($! =~ /No more process/) {

			# EAGAIN, supposedly recoverable fork error
			sleep 5;
			redo FORK;

		} else {
			# weird fork error
			warn "Can't fork: $!\n";
		}
	}
}




#       pager - show a string through $ENV{'PAGER'}
sub pager {
        local (*pager_str) = @_;

        &cbreak_off;
        unless (open (PAGER, "| $ENV{'PAGER'}")) {
                warn "can't set up pager!: !$\n";
                return 1;
        }
        print PAGER $pager_str;
        close PAGER;
        &cbreak_on;
        if ($ENV{'PAGER'} =~ /.*more/) {
                print TTYOUT "\tpress any key..."; &flush;
                read (TTYIN, $ans, 1);
        }
        1;
}


#	arrive - show a string temporarily...
sub arrive {
	$arrived_str = @_[0];
	$as_len = length($arrived_str);
	$saveme = $|;
	$| = 1;
	print TTYOUT "$arrived_str";
	1;
}

#	depart - take away an arrived string...
sub depart {
    $saveme = $|;
    $| = 1;
    print TTYOUT "\b \b" x $as_len;
    $| = $saveme;
    1;
}

#	newest_file - return newest filename out of an array of them
sub newest_file {
    local(@the_filenames) = @_;
    local($mtime);
    @foo = ();
    %newest = ();

    while ($compare = shift(@the_filenames)) {
	if (-e $compare) {
	    $mtime = ((stat($compare))[9]);
	    $newest{"$mtime $compare"} = $compare;
	}
    }
    @foo = sort keys %newest;
    return $newest{$foo[$#foo]};
}

#	which - traverse $ENV{'PATH'}
sub which {
    local(@the_whiches) = @_;
    local($this_which);
    
    while ($this_which = shift @the_whiches) {
	foreach (split(/:/, $ENV{"PATH"})) {
	    print TTYOUT "$_" . '/' . "$this_which\n" if -x "$_/$this_which";
	}
    }

}


#	from this point on, we get into late evening craziness.

#	happy_strings - grabbag of string effects, add your favorite
sub happy_strings {
    local($flush_state) = $|;
    local($i, $l);
    local($effect, $line) = @_;

    $| = 1;

    if ($effect == 1) {
	for (reverse split(/ /, $line)) {
	    print TTYOUT $l = $_. ' ' . $l, "\015";
	    sleep 1;
	}
    }

    if ($effect == 2) {
	print TTYOUT reverse split(//, $line);
    }


    # scooter
    if ($effect == 3) {
	print TTYOUT "\n";
	local($the_len) = length($line);
	for (1..$the_len) {
	    $known_line = substr($line, 0, $_);
	    $scoot = (79 - $_);
	    $cur_scoot = substr($line, $_, 1);
	    print TTYOUT "\015$known_line", " " x $scoot, $cur_scoot;
	    while ($scoot-- > $the_len) {
		print TTYOUT "\b \b\b$cur_scoot", "\000" x 100;
	    }
	}
	print TTYOUT "\015$the_line";
    }

    # center
    if ($effect == 4) {
	for (1..length($line)) {
	    print TTYOUT
		&center(substr($line, 0, $_)) . "\015" . "\000" x 4000;
	}
    }
    $| = $flush_state;
    1;
}
1;