############################################################################
#  pcmd - perl bindings for wafe.
#
#  Dov Grobgeld
#  Department of Chemical Physics
#  The Weizmann Institute of Science
#  Israel
#  
#  Version: 0.2
#
#  pcmd is donated to the Public Domain.
#
#  wafe is Copyright (C) 1993 by Gustaf Neumann
#
#      Wirtschaftsuniversitaet Wien,
#      Abteilung fuer Wirtschaftsinformatik
#      Augasse 2-6,
#      A-1090 Vienna, Austria
#      neumann@wu-wien.ac.at, nusser@wu-wien.ac.at
#
#
############################################################################
# 
#  pcmd is a procedure which should be called whenever the event loop
#  receives a string starting with "pcmd:". pcmd is an abbreviation for
#  "perl-command" and is meant to be a way to write high-level commands
#  in perl.
# 
#  The following example provides the correct syntax for using pcmd
#  
#  while (<>) {        # Main event loop
#      if (/pcmd:/) {
#          &pcmd($');
#      }
#      :
#  }
#  
#  The following is an example of a key binding which will invoke a 
#  pcmd command:
# 
#     Shift<Key>F7: exec(echo "pcmd:unindent %w")
#     Shift<Key>F8: exec(echo "pcmd:indent %w")
# 
#  (Note that the examples above have been given without the needed perl 
#  quoting)
#  
#  The commands that are provided are:
#     indent -  indent the current paragraph four spaces
#     unindent - unindent the current paragraph four spaces
#
#  Also provided in the package are the subroutines
#     getSelection(w)   - returns the selection from the window w
#     setSelection(w,s) - exchanges the selection in widget w with the 
#                         string s.
#
############################################################################

sub pcmd {
    local($_)=@_;
    local($command, $w);

    s/pcmd://;  # Erase "pcmd:" if it is still there
    ($_, $w)= /(\S+)\s+(\S+)/;
    
    if (/^indent/) {
        local($_)=&getSelection($w);
        if (/\n$/) {
            chop; $*=1; $ip=s/^.+/    $&/g; $*=0; $_="$_\n";
        }
        else { $*=1; $ip=s/^/    /g; $*=0; }
        &setSelection($w,$_);
        &UI("textSetInsertionPoint $w [expr [textGetInsertionPoint $w]+$ip*4]\n");
    }
    elsif (/^unindent/) {
        local($_)=&getSelection($w);
        if (/\n$/) {
            chop; $*=1; $ip=s/^    //g; $*=0; $_="$_\n";
        }
        else { $*=1; $ip=s/^    //g; $*=0; }
        &UI("textSetInsertionPoint $w [expr [textGetInsertionPoint $w]-$ip*4]\n");
        &setSelection($w,$_);
    }
}

# Some Tcl convenience routines 
&main'TclProc('
proc getTextSelection {w} { 
   textGetSelectionPos $w from to;
   if $from!=$to {
       set length [expr $to-$from];
       for {set toread $length; set read 0; set content ""} {$read<$length}
           {set from [expr $from+$text(length)]; set toread [expr $length-$read]}
           {
	       textSourceRead $w $from text $toread; 
               set read [expr $text(length)+$read]; 
               set content $content[string range $text(ptr) 0 [expr $text(length)-1]]
           };
           set result [string range $content 0 $length];
   } {set result ""};
   return $result
}

proc setTextSelection {w text} {
    textGetSelectionPos $w from to; 
    set txt(ptr) $text; 
    set txt(firstPos) 0; 
    set txt(length) [string length $text]; 
    textReplace $w $from $to txt; 
    textSetSelection $w $from [expr $from+$txt(length)];
}

proc searchText {w dir string} { 
   textSetInsertionPoint $w [expr [textGetInsertionPoint $w]+1];
   set textSearch(ptr) $string;
   set textSearch(length) [string length $string];
   set textSearch(firstPos) 0;
   set ip [textSearch $w $dir textSearch];
   if {$ip<0} then { 
          textSetInsertionPoint $w [expr [textGetInsertionPoint $w]-1]; 
          return 0
      } else { 
	  textSetInsertionPoint $w $ip; 
	  textSetSelection $w $ip [expr $ip+$textSearch(length)]; 
	  return 1
      }
}
');

# Some perl convenience routines to interface wafe

# getSelection returns a string containing the current selection in
# the editor window.

sub getSelection {
    local($w) = @_;
    local($l,$_);
    &Xui("echo [getTextSelection $w]; echo __EnD__Of__FiLe__");
    $l.=$_, $_=<> until /^__EnD__Of__FiLe__$/;
    
    # erase last newline which echo provides.
    chop($l);
    return $l;
}


# setSelection will replace the current selection with the argument
# string.
sub setSelection {
    local($w,$_)=@_;
    &Xui("setTextSelection $w ".&tclQuote($_));
}

sub widgetContent {
    local($filename,$widget) = @_;
    local($ds,$content) = ($/);

    &main'Xui("asciiSaveAsFile $widget $filename;echo done");
    $_ = <STDIN>; # we have to wait, until the file is saved!
    undef $/;  open(F,"<$filename") && ($content = <F>) && close(F); $/ = $ds;
    $content;
}

# Quote a tcl string. This routine is probably buggy...
sub tclQuote {
    local($_)=@_;

    s/[ \{\}\[\]\\\"\$\;]/\\$&/g;
    s/\n/\\n/g;
    s/\t/\\t/g;
    
    $_= "{$_}" if /^$/;
    $_;    
}

1;