
# Misc stuff.
#
#
# Copyright (c) 1993 ICEM Systems.
# Author:  Wayne A. Christopher, wayne@pmac.com
#          Pacific Marketing and Consulting, Berkeley, California

proc print_file {filename} {
    global printer_name
    
    ** currently unused **
    
    if [file exists /usr/bin/lp] {
	set com "/usr/bin/lp -d$printer_name $filename"
    } elseif [file exists /usr/bin/lpr] {
	set com "/usr/bin/lpr -P$printer_name $filename"
    } elseif [file exists /usr/ucb/lpr] {
	set com "/usr/ucb/lpr -P$printer_name $filename"
    } else {
	mess "I don't know how to print files on this system\n"
	return
    }
    if [catch {eval exec $com} ret] {
	mess "Error: Couldn't print the file: $ret\n" red
    } else {
	mess "Sending file \"$filename\" to printer.\n"
    }
}

proc numsort {names} {
    set fnames {}
    foreach n $names {set fnames "$fnames \"[format "%10d" $n]\""}
    set list [lsort $fnames]
    set fnames {}
    foreach n $list {eval append fnames {" "} $n}
    return $fnames
}

proc lfirst {list} {lindex $list 0}
proc llast {list} {lindex $list [expr {[llength $list] - 1}]}

proc max { a b } { return [expr ($a > $b)? $a : $b] }

proc old_lreplace {list index new} {
    set ind 0
    set newlist {}
    foreach elem $list {
	if {$ind == $index} {
	    lappend newlist $new
	} else {
	    lappend newlist $elem
	}
	incr ind
    }
    return $newlist
}

proc ldelete {list elem} {
    set res {}
    foreach l $list {
	if {$l != $elem} {lappend res $l}
    }
    return $res
}

proc lmember {list elem} {
    foreach l $list {
	if {$l == $elem} {return 1}
    }
    return 0
}

proc first_existing_font {fonts} {
    foreach f $fonts {
	catch {destroy .xxx}
	if {![catch "toplevel .xxx; button .xxx.yyy -font $f"]} {
	    destroy .xxx
	    return $f
	}
    }
    puts stderr "Fatal error: no fonts available from list: $fonts"
    exit 1
}

proc read_token {f} {
    global cur_read_line
    
    if {![info exists cur_read_line($f)]} {
	set cur_read_line($f) [gets $f]
    }
    while 1 {
	set tok [lfirst $cur_read_line($f)]
	set cur_read_line($f) [lrange $cur_read_line($f) 1 end]
	if {$tok == ""} {
	    set cur_read_line($f) [gets $f]
	    if [eof $f] {
		unset cur_read_line($f)
		return ""
	    }
	} else {
	    return $tok
	}
    }
}

proc locate_useful_programs {} {
    # These pathnames are never the same and we can't trust people to have
    # reasonable paths.
    
    set programs {
	uname
	whoami
	date
	vi
	xterm
	scrsave
	ps
    }
    
    set directories {
	/bin
	/usr/bin
	/usr/sbin
	/usr/ucb
	/usr/bsd
	/usr/X11/bin
	/usr/bin/X11
	/usr/openwin/bin
    }
    
    foreach p $programs {
	global ${p}_path
	foreach d $directories {
	    if [file exists $d/$p] {
		set ${p}_path $d/$p
		break
	    }
	}
	if {![info exists ${p}_path]} {
	    puts stdout "Warning: can't find the \"$p\" program on this system"
	    set ${p}_path $p
	}
    }    
}

proc get_path {what {check 0}} {
    global program_paths env
    
    if [info exists program_paths($what)] { return $program_paths($what) }
    
    if {$what == "rsh"} {
	# This one gets special treatment.
	set rsh [get_path remsh 1]
	if {($rsh == "") && [file exists /usr/bsd/rsh]} {
	    set rsh /usr/bsd/rsh
	}
	if {$rsh != ""} {
	    set program_paths(rsh) $rsh
	    return $rsh
	}
    }
    
    set dirs ""
    if [info exists env(PATH)] {
	set dirs [split $env(PATH) :]
    }
    
    foreach dir {
	/bin
	/usr/bin
	/usr/sbin
	/usr/ucb
	/usr/bsd
	/usr/openwin/bin
	/usr/X11/bin
	/usr/bin/X11
	/etc
	/usr/etc
    } {
	lappend dirs $dir
    }
    
    foreach dir $dirs {
	if {[file executable $dir/$what] && ![file isdirectory $dir/$what]} {
	    set program_paths($what) $dir/$what
	    return $dir/$what
	}
    }
    
    if $check { return "" }
    
    mess "Warning: can't run the \"$what\" program on this system\n" red
    set program_paths($what) $what
    return $what
}

# This is from Karl Lehenbauer (karl@neosoft.com), modified somewhat.

proc static {args} {
    global staticvars
    
    set procName [lindex [info level -1] 0]
    set name [lindex $args 0]
    uplevel 1 "upvar #0 staticvars($procName:$name) $name"
    if {[llength $args] > 1} {
	if ![info exists staticvars($procName:$name)] {
	    set staticvars($procName:$name) [lindex $args 1]
	}
    }
}

# This is from Michael Salmon (etxmesa@eos.ericsson.se), modified somewhat.

proc random {limit} {
    static seed
    
    if {![info exists seed]} {
        set seed [expr [exec [get_path date] +1%S%M%H%j]%100000]
    }
    set seed [expr (($seed*21421)+1)%100000]
    
    return [expr {int(($seed / 100000.0) * $limit)}]
}

proc determine_memory {} {
    set hinv [get_path hinv 1]
    set lsdev [get_path lsdev 1]
    set grep [get_path grep 1]
    
    if {$grep == ""} { return 0 }
    
    if {$hinv != ""} {
	if ![catch {exec $hinv | $grep "Main memory"} memline] {
	    if [regexp {: ([0-9]+)} $memline dummy mem] {
		return $mem
	    }
	}
    }
    
    if {$lsdev != ""} {
	if ![catch {exec $lsdev -C | $grep ^mem} memlines] {
	    set mem 0
	    foreach memline [split $memlines \n] {
		if [regexp { ([0-9]+) MB} $memline dummy mem1] {
		    incr mem $mem1
		}
	    }
	    if $mem { return $mem }
	}
    }
    
    set messfiles [lsort [glob_fixed /usr/adm/messages*]]
    
    foreach mess $messfiles {
	if ![catch {exec $grep ": mem" $mess} stuff] {
	    if [regexp {mem = ([0-9]+)} $stuff dummy mem] {
		return [expr {$mem / 1000}]
	    }
	}
    }
    foreach mess $messfiles {
	if ![catch {exec $grep "real mem" $mess} stuff] {
	    if [regexp {mem = ([0-9]+)} $stuff dummy mem] {
		return [expr {$mem / 1000}]
	    }
	}
    }
    return 0
}

# ---------------------

proc run_background {cmd dir wait {finish_string ""} {ignore_pats ""} \
			 {error_pats ""} {allow_errors 1} {extra_check ""}} {
    global run_background_fp run_background_eof run_background_fstring
    global run_background_ignore_pats run_background_error_pats
    global run_background_pid run_background_last_output is_win tcl_platform
    global run_background_diag_info
    
    set run_background_diag_info ""
    
    # Just in case we get called with a bad pathname
    if [string match "not_found*" $cmd] {
	set run_background_diag_info "Error: the program was not found\n"
	mess $run_background_diag_info red
	return 0
    }
    
    set run_background_fstring $finish_string
    set run_background_ignore_pats $ignore_pats
    set run_background_error_pats [concat $error_pats [list "*child killed:*"]]
    set run_background_last_output ""
    
    set here [pwd]
    if {$dir != ""} { cd $dir }
    if {$wait == 3} {
	if {$tcl_platform(platform) != "windows"} {
	    set wait 1
	} else {
	    vmess "[backslashify $cmd]\n"
	    vmess "(on Windows, output will not appear until the program terminates...)\n"
	    
	    set res [catch {eval exec $cmd} stuff]
	    cd $here
	    foreach line [split $stuff \n] {
		set ok 1
		foreach p $run_background_ignore_pats {
		    if [string match $p $line] { set ok 0; break }
		}
		if $ok {
		    vmess $line\n orange "" 0
		}
	    }
	    if $res {
		set run_background_diag_info "Exit status: $res\nOutput from program: $stuff\n"
		return [expr $allow_errors]
	    } else {
		return 1
	    }
	}
    }
    set fp [open "|$cmd" r]
    cd $here
    
    set run_background_pid [pid $fp]
    
    vmess "Pid $run_background_pid: [backslashify $cmd]\n"
    
    set jname [file rootname [file tail [lindex $cmd 0]]]
    if !$is_win { jobs_add $run_background_pid $jname $cmd }
    
    fileevent $fp readable "run_background_line $fp"
    
    switch $wait {
	0 { return 1 }
	1 {
	    if {$extra_check != ""} {
		set cancel [after 5000 run_background_extra_check $fp \"$extra_check\"]
	    } else {
		set cancel ""
	    }
	    
	    vwait run_background_eof($fp)
	    if [string compare "0" [lindex $run_background_eof($fp) 0]] {
		if $allow_errors {
		    mess "Error: [lindex $run_background_eof($fp) 1]\n" red
		} else {
		    vmess "[lindex $run_background_eof($fp) 1]\n" orange
		    vmess "Done.\n"
		}
		if [info exists run_background_pid] {
		    if !$is_win { jobs_remove $run_background_pid }
		    catch {cmd_kill $run_background_pid}
		    unset run_background_pid
		}
		catch {close $fp}
		if {$cancel != ""} { after cancel $cancel }
		set run_background_diag_info $run_background_eof($fp)
		return [expr !$allow_errors]
	    } else {
		if {$cancel != ""} { after cancel $cancel }
		vmess "Done.\n"
		return 1
	    }
	}
	2 {
	    vwait run_background_eof($fp)
	    vmess "[lindex $run_background_eof($fp) 1]\n" blue
	    vmess "Done.\n"
	    if [info exists run_background_pid] {
		if !$is_win { jobs_remove $run_background_pid }
	    }
	    return 1
	}
    }
}

proc run_background_terminate {} {
    global run_background_pid 
    if [info exists run_background_pid] { cmd_kill $run_background_pid }
}

proc run_background_extra_check {fp cmd} {
    global run_background_eof run_background_pid errorCode
    
    if [eval $cmd] {
	mess "Warning: terminated process using extra check\n" red
	if [catch {close $fp} res] {
	    set run_background_eof($fp) [list [lindex $errorCode 2] $res]
	} else {
	    set run_background_eof($fp) 0
	}
	catch {unset run_background_pid}
    } else {
	after 5000 run_background_extra_check $fp \"$cmd\"
    }
}

proc run_background_line {fp} {
    global run_background_eof errorCode run_background_pid
    global run_background_fstring run_background_ignore_pats
    global run_background_error_pats run_background_last_output
    
    if [eof $fp] {
	if {[catch {close $fp} res] && \
		![string match "*Checking out a connection license*" $res]} {
	    set run_background_eof($fp) [list [lindex $errorCode 2] $res]
	} else {
	    set run_background_eof($fp) 0
	}
	catch {unset run_background_pid}
    } else {
	set line [gets $fp]
	append run_background_last_output $line\n
	set ok 1
	foreach p $run_background_ignore_pats {
	    if [string match $p $line] { set ok 0; break }
	}
	if $ok {
	    vmess $line\n orange "" 0
	}
	foreach p $run_background_error_pats {
	    if [string match $p $line] {
		set mess "Problem found with mesher input: please contact technical support\n$line"
		set run_background_eof($fp) [list 1 $mess]
		#puts "run_background_eof($fp) is $run_background_eof($fp)"
		return
	    }
	}
	
	if {($run_background_fstring != "") && \
		[string match *$run_background_fstring* $line]} {
	    close $fp
	    set run_background_eof($fp) 0
	    catch {unset run_background_pid}
	}
    }
}

proc license_server_lost {mess exiting} {
    switch -- $exiting {
	0 {
	    mess "$mess\n" red
	}
	1 {
	    mess "$mess\n" red
	    if [db_check_dirty model] {
		file_save 0
		mess "Automatically saved project.\n" red
		puts "Automatically saved project."
	    }
	}
	-1 {
	    mess "$mess\n"
	}
    }
}
