#-*-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 = "3c:$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",
	       "3", "3d: disable three-D effects (libXaw3d)",
	       );
    $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";
    }
    print $errString,"\n%quit\n";
}

#
# definining global directory and file names, setting up perl include path
#
$WafeBitmaps = "$WafeLib/bitmaps";
$configFiles = "$ENV{'HOME'}/.wafe_options:$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;} 

# try different semantics for different perl versions
$_="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($_);
}

sub TclProc {
    local($_) = @_;
    $*=1;
    s/^[ \t]+//g; #remove leading spaces
    s/^#.*//g; # remove comments    
    foreach (split(/\n\n+/)) {  # each paragraph is a procedure
	s/\n/ /g;  # join lines
	&Xui($_);
    }
    $*=0;
}

# set infoline to string
sub info {
    local($_,$beep) = @_;
    tr/\n/ /;
    &Xui('bell info 0') if $beep;
    &Xui("sV info label {$_}");
}
sub warn { &info($_[0],1); }

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


#
# read configuration file
#
sub read_config {
    local($_,$configFile);
    foreach $configFile ((split(':',$configFiles))) {
#	print "trying configuration file $configFile\n";
	do $configFile;
    }
# print "Boldfont = $boldFont\n", join("\n",@FtpServers),"\n";
}

#
# figure out, what is complied into wafe
#
package wafe;

&main'Xui('echo [getChannel] $WAFEVERSION: $XVERSION $PACKAGES');
$_ = <STDIN>;
($KANAL,$WafeVersion,$XVersion,$Packages) = 
    m/^\s*(\d+)\s+([^:]+):\s+(\S+)\s+(.*)$/;
$KANAL += 0;
open(TUNNEL,"+>&$KANAL");
select(TUNNEL); $| = 1;
select(STDOUT);


#
# excursion to main (we might need packages during the configuration)

package main;

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



#
# localized conveniance routines
#

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) = @_;
    local(@specs);
    foreach $w (keys %ressources) { 
#	print "$w <- <$ressources{$w}>\n";
	$ressources{$w} =~ s/^\s+//;
	@specs = split(/\s+/,$ressources{$w});
	for ($i=$[; $i<$#specs; $i +=2) {
#	    print "mergeResources topLevel $w*$specs[$i] ".$specs[$i+1],"\n"; 
	    &main'Xui("mergeResources topLevel $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;
    }
}


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";
$SIG{'PIPE'} = "wafe'cleanup";
$SIG{'TSTP'} = 'IGNORE';   # to avoid SGCLD for parent when it is stopped

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

#
# participate in delete window protocol
&main'TclProc('
proc deleteWindowProtocol {cmd} {
    setWMProtocols topLevel WM_DELETE_WINDOW;
    action topLevel override "<Message>WM_PROTOCOLS: exec($cmd)"
}');


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


1;