#-*-perl-*-
#
# Copyright (C) 1992 by Gustaf Neumann, Stefan Nusser
#
#      Wirtschaftsuniversitaet Wien,
#      Abteilung fuer Wirtschaftsinformatik
#      Augasse 2-6,
#      A-1090 Vienna, Austria
#      neumann@wu-wien.ac.at, nusser@wu-wien.ac.at
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appears in all copies and that both that
# copyright notice and this permission notice appear in all supporting
# documentation.  This software is provided "as is" without expressed or
# implied warranty.
#
# Date: Mon, Apr 13 1992
# Author: Gustaf Neumann
# Version: 0.9
#

($appName) = ($0 =~ m&([^/]+)$&);

$options = "c:$options";
foreach (keys %privOptions) {
    $options .= $_ .  ((split(/:/,$privOptions{$_}))[$[] ne "" ? ":" : "");
}

require 'getopts.pl';
if (!&Getopts($options)) {
    %Options = (
	       "c", "color mode: such as grayish or blueish or greenish",
	       "u", "update: update each X seconds",
	       );
    $errString  = "\nusage: x$appName [-<options>] ...\n";
    foreach $key (split(/:*/,$options)) {
	($short,$long) = split(/: /,$privOptions{$key} || $Options{$key});
	$errString .= substr("   -$key ".($short eq "" ? "" : "<$short>").(" " x 30),0,30)
			     ."## $long\n";
    }
    die $errString,"\n";
}

#
# definining global directory and file names, setting up perl include path
#
$WafeBitmaps = "$WafeLib/bitmaps";
$configFiles = "$WafeLib/system.waferc:$ENV{'HOME'}/.waferc";
$tmpDir = $ENV{'TMPDIR'} || '/tmp';
unshift(@INC,"$WafeLib/perl");

#
# user interface communication routines
#

sub Xui { local($_)= @_; $|=1; s/^/%/g; print "$_\n"; 1;} 

# for users of perl4.010
$_="1\n2";s/^/%/g; 
eval 'sub Xui { $|=1; foreach(split(/\n+/,$_[$[])) { print "%$_\n";} 1;}' if tr/%/%/<2;

sub UI {  local ($_) = @_;
    $*=1;
       s/^#.*//g; s/\n#.*//g;  # remove comments    
       s/\\[ \t]*\n\s*//g;   # resolve continuation lines
       s/\n\s*/\n/g; #remove empty lines
       s/\n*$//g; #trailing newlines
    $*=0;
    &Xui($_);
}

# set infoline to string
sub info {
    local($_) = @_;
    tr/\n/ /;
    &Xui("sV info label {$_}");
}

sub simpleMenue {
    local($f,$target,$type,@entries) = @_;
    for (@entries) {
	($w = $_) =~ tr/*. /---/;
#	print "<$w>smeBSB {$f$w} $f label {$_} $normalFont\n"
#	    ."callback {$f$w} callback exec {sV $target $type {$_};echo $target $_}\n";
	&Xui("smeBSB {$f$w} $f label {$_} $normalFont");
	&Xui("callback {$f$w} callback exec {sV $target $type {$_};echo $target $_}");
    }
}


#
# read configuration file
#
sub read_config {
    local($_,$configFile);
    foreach $configFile ((split(':',$configFiles))) {
#	print "trying configuration file $configFile\n";
	if (open(CONFIG,"<$configFile")) {
	    undef($/); $_ = <CONFIG>; $/="\n";
	    close(CONFIG);
	    $*=1;
	    s/^;?#.*//g; s/\n;?#.*//g;  # remove comments    
	    s/\n([^\n])/$1/g;   # join to paragraphs
	    s/\n\s*/\n/g; s/^\s*//g; #remove empty lines
	    $*=0;
	    for (split("\n")) {
		eval $_;
		print "ERROR in configuration file $configFile: $@\n" if $@;
#		print "eval: $_\n";
	    }
	}
    }
# print "Boldfont = $boldFont\n", join("\n",@FtpServers),"\n";
}

&read_config();
&Xui("sV topLevel iconPixmap $WafeBitmaps/wafe.xbm");
&Xui("mergeResources $defaultResources") if $defaultResources;

#
# conveniance routines, which are localized
#
package wafe;


#
# tmpFile
#
sub tmpFile {
    local($fileName) = "$main'tmpDir/$_[0]$$";
    $toRemove .= $fileName . ' ';
    return $fileName;
}

#
# readTimeout
#
sub readTimeout {
    local($timeout) = @_;
    local($nfound,$timeleft,$_);
    $rin = ''; vec($rin, fileno(STDIN), 1) = 1;
    ($nfound, $timeleft) = select($rout=$rin, undef, undef, $timeout);
    return "timeout" if !$nfound;
    $_ = <STDIN>;
    &cleanup() unless($_);   # we have read something empty! assume dead father
    chop($_);
    $_;
}


sub fileTransaction {
    local($fname,$perlCode) = @_;
#    print "file transaction for <$fname>, locks = $locks{$fname}, <$perlCode> \n";
    if (!$locks{$fname}) {
	$locks{$fname} ++;
	eval $perlCode;
	print "ERROR: $@\n" if $@;
    } else {
#	print "+++ i have to block for <$fname>\n";
	$blocked{$fname} = $perlCode;
    }
}

sub setWidgetToFile {
    local($widget,$fname) = @_;
#    print "setting widget $widget to file $fname\n";
    &main'Xui("sV $widget type file string $fname;echo unlockTW $fname");
}

sub unlockTextWidget {
    if (/^unlockTW\s+(\S*)/) {
	local($fname) = $1;
#print "+++ received unlock <$fname>\n";
	return if !$locks{$fname};
        $locks{$fname}--;
#print "+++ there are locks <$locks{$fname}>\n";
        return if !$blocked{$fname};        
#print "+++ UNLOCK: <$locks{$fname}> executing blocked code for $fname <$blocked{$fname}>\n";
	eval $blocked{$fname};
	print "ERROR: $@\n" if $@;
        $blocked{$fname} = '';
    }
}

#
# applying actions to a widget
#
sub applyActions {
    local($widget,@actions) = @_;
    for (@actions) { &main'Xui("action $widget override {$_}"); }
}
#
# provide ressources defaults a widget (class)
#
sub setResources {
    local($widget,%ressources) = @_;
    foreach $w (keys %ressources) { 
#	print "$w <- <$ressources{$w}>\n";
	$ressources{$w} =~ s/^\s+//;
	local(@specs) = split(/\s+/,$ressources{$w});
	for ($i=$[; $i<$#specs; $i +=2) {
#	    print "mergeResources $w*$specs[$i] ".$specs[$i+1],"\n"; 
	    &main'Xui("mergeResources $w*$specs[$i] ".$specs[$i+1]); 
	}
    }
}			      

#
# maintaining the sensitivity state of a widget
#
sub sensitive {
    local($B,@widgets) = @_;
    local(@T) = ("undefined","false","true");
    $B++;
    for (@widgets) {
	&main'Xui("sV $_ sensitive $T[$B]"), $Sensitive{$_}=$B
	     unless $Sensitive{$_} == $B;
    }
}

&main'Xui("echo [getChannel];");
chop($KANAL = <STDIN>); $KANAL+=0;
open(TUNNEL,">&$KANAL");
select(TUNNEL); $| = 1;
select(STDOUT);

sub tunnel {
    local($towrite,$written);
    $towrite = length($_[1]);
#    $written = syscall(4,$KANAL,$_[1],$towrite);
    print TUNNEL $_[1];
#    print "***** i should write $towrite, but i have written $written *****\n" 
#	if ($towrite != $written);
#    print "i do now setCommunicationVariable $_[0] $towrite {$_[2]}\n";
    &main'Xui("setCommunicationVariable $_[0] $towrite {$_[2]}");
}


$SIG{'INT'} = "wafe'cleanup";
$SIG{'QUIT'} = "wafe'cleanup";
$SIG{'STOP'} = "wafe'cleanup";
$SIG{'HUP'} = "wafe'cleanup";
$SIG{'TERM'} = "wafe'cleanup";

sub cleanup {
    local($sig) = @_;
    print "Caught signal $sig -- shutting down\n";
    for ((split(' ',$toRemove))) {
#        print "must remove $_\n";
        unlink $_;
    }
   &main'Xui("quit");
   exit;
}

#
# initializing variables for select
#
$rin = $win = $ein = '';
vec($rin, fileno(STDIN), 1) = 1;
vec($win, fileno(STDOUT), 1) = 1;
$ein = $rin | $win;


1;
