#-*-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.
#
# functionality for $perlOnTop mostly due to
# Wayne Scott <wscott@ichips.intel.com>
#
# Date: Mon, Apr 13 1992
# Author: Gustaf Neumann
# Version: 0.96
#

#$perlOnTop = 1;

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

# check first for $perlOnTop
@ARGV = grep(!/^-P/ || ($perlOnTop = !$perlOnTop, 0), @ARGV);

if ($perlOnTop) {
    foreach (@ARGV) {
	# for arguments after flags
	push(@WafeArgs,$_), $pushArg=0, next if $pushArg;
	$ignoreArg=0, next if $ingoreArg;

	#ignoring certain Wafe flags and arguments
	next if /^\-\-[cdfinv]/;
	$ignoreArg=1, next if /^\-\-[pT]/;

	# find wafe's arguments
	push(@WafeArgs,$_), $pushArg=1, next 
	    if /^\-(fn|display|title|name|foreground|background|font|xrm|borderWidth|borderwidth|fg|bg)/;
	push(@WafeArgs,$_), next if /^\-(\-|iconic|reverse|rv)/;

	# the remainder is for perl
	push(@LocalArgs,$_);
    }
    @ARGV = @LocalArgs;
    undef @LocalArgs;
}



$options = "P3c:$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",
	       "3", "3d: disable three-D effects (libXaw3d)",
	       "P", "Perl on top: run wafe as a subprocess",
	       );
    $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 STDERR $errString;
    exit;
}

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


# try different semantics for different perl versions
$*=1;
$_="1\n2";s/^/%/g; 
$earlyPerl = (tr/%/%/<2);
$*=0;

if ($perlOnTop) {
    $WafeBin = "wafe" unless defined $WafeBin;
    require 'open2.pl';
    socketpair(S0,S1,1,1,0);
    $pidwafe = &open2('WAFE', 'toWAFE', 
		      "$WafeBin --d --n --C$appName "
		      ."--T ".fileno(S0).'/'.fileno(S1)
		      ." ".(join(" ",@WafeArgs)));
    undef @WafeArgs;
    select(toWAFE); $|=1; select(STDOUT); 
    $toWAFE = toWAFE;
    eval <<'Wafe IO';
    sub Xui { 
       local($_) = @_; 
       print toWAFE "$_\n"; 
    }

    sub wafe'read {
       <main'WAFE>;
    }
Wafe IO

} else {
    # Wafe is on top
    select(STDOUT); $|=1;

    if ($earlyPerl) {
	eval 'sub Xui {foreach(split(/\n+/,$_[$[])) {print "%$_\n";} 1;}';
    } else {
	eval 'sub Xui { local($_)=@_; s/\n+$//; local($*)=1; s/^/%/g; print "$_\n"; 1;}';
    }
    $toWAFE = STDOUT;
    $*=0;
    eval <<'Wafe IO';
    sub wafe'read {
       <STDIN>;
    }
Wafe IO
} #'  
undef $earlyPerl;

sub TclSet { 
    local($var,$_) = @_; 
    local(@lines) = split(/\n/,$_);
    local($promptChar) = ($toWAFE eq STDOUT) ? '%' : '';
    if ($#lines == 0) {
	s/\n+$//; # seems to be a bug in split
	print $toWAFE "$promptChar=$var $_\n";
    } else {
	local($first) = shift(@lines);
	print $toWAFE "$promptChar=$var $first\n";
	foreach (@lines) { print $toWAFE "$promptChar/$var $_\n"; }
    }
    1;
}

#
# user interface communication routines
#

sub UI {  
    local ($_) = @_;
    local ($*) = 1;

    s/^\s*#.*$//g; 	# remove comments
    s/\\\s*\n\s*/ /g;   # resolve continuation lines

    s/\n\s*/\n/g;       # remove empty lines
    s/\n*$//g;          # trailing newlines
    $*=0;
    &Xui($_);
}


# tclProc sends each paragraph with a single Xui to Wafe
# no continuation lines are resolved

sub TclProc {
    local($_) = @_;
    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($_);
    }
}

# for the few people that use TclCmd of the alpha release
sub TclCmd {
    local($_) = @_;

    if (0) {
	local ($*) = 1;
	s/^[ \t]+//g;       # remove leading spaces
	s/^#.*//g;          # remove comments

	&TclSet('_',$_);
        # the only reason for using wafeEval instead of eval
        # is the better error message!
	&Xui('wafeEval $_;unset _');
    } else {
	&Xui($_);
    }

}

sub TclQuote {
    local($_) = @_;
    s/[\{\}\[\]\\\"\$\;]/\\$&/g;
    return "\"$_\"";
}

# 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 $_}");
    }
}


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

&main'Xui('echo [getChannel] $WAFEVERSION: $XVERSION $PACKAGES');
$_ = &wafe'read;
($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 configuration file
#
sub read_config {
    local($_,$configFile);
    foreach $configFile ((split(':',$configFiles))) {
#	print "trying configuration file $configFile\n";
	do $configFile;
    }
}
&read_config();

&Xui("set FILESEARCHPATH $WafeBitmaps");
&Xui("sV topLevel iconPixmap 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 = ''; 
    if ($main'perlOnTop) {
       vec($rin, fileno(main'WAFE), 1) = 1;
    } else {
       vec($rin, fileno(STDIN), 1) = 1;
    }
    ($nfound, $timeleft) = select($rout=$rin, undef, undef, $timeout);
    return "timeout" if !$nfound;
    $_ = &read;
    &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,%resources) = @_;
    local(@specs);
    foreach $w (keys %resources) {
#	print "$w <- <$resources{$w}>\n";
	$resources{$w} =~ s/^\s+//;
	@specs = split(/\s+/,$resources{$w});
	for ($i=$[; $i<$#specs; $i +=2) {
	    &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{'HUP'} = "wafe'cleanup";
$SIG{'TERM'} = "wafe'cleanup";
$SIG{'PIPE'} = "wafe'cleanup";
$SIG{'TSTP'} = 'IGNORE' 
    unless $main'perlOnTop;   #' 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 = '';
if ($main'perlOnTop) { #'
   vec($rin, fileno(main'WAFE), 1) = 1;  #'
   vec($win, fileno(main'toWAFE), 1) = 1; #'
} else {
   vec($rin, fileno(STDIN), 1) = 1;
   vec($win, fileno(STDOUT), 1) = 1;
}
$ein = $rin | $win;


1;
