package provide Expect 0.21.08.11

# <20210811.1736.48>

# This is a tcl implementation of expect.  It is a subset of the full
# expect program, BUT it is all pure tcl.
#
# spawn [args] program [args]
#
# The inital set of args are: 
# -noecho  
# -console (ignored)  
# -open (not yet error)  
# -leaveopen (not yet error) 
# -pty (not yet error)  
# -ignore (not yet error)
# --      end of '-' options
#
# The first argument with out a preceeding '-' is the program name and
# the following arguments are passed to it.
# The return value is the spawn_id (which is also global)

# A note on scoping.  We do NOT attempt to look any special place
# for variables read (as the real expect for variables written).  

# We do, however, keep a global store for each open 'spawn_id' and we execute
# the pattern scripts in the stack of the caller.  That means that the 
# following vars will be created there if they are not in that scope:
# expect_out(buffer)  
# expect_out(1,string) through  expect_out(9,string)
# expect_out(1,start) through  expect_out(9,start) 
# expect_out(1,end) through  expect_out(9,end) 

proc exp_spawn {args } { 
  eval spawn $args
}
 
proc spawn {args } {
  global expecta
  set noecho 0
  set prog {}
  set pargs {}
  foreach arg $args {
    if { $prog != {} } {
      append pargs " " \"$arg\"
      continue
    }
    switch -exact $arg {
      -noecho { set noecho 1}
      -console {}
      -open -
      -leaveopen -
      -pty -
      -ignore  {return -code  error "option $arg is not yet supported" }
      -- -
      default {set prog $arg}
    }
  }
  if {$prog == {} } {
    return -code error "spawn called with no program"
    return {}
  }
  if {$noecho == 0} {
    puts "$prog [join $pargs]"
  }
  Log_exp "spawn: $prog $pargs"
  set r [catch {open "|  $prog  $pargs  2>@1" r+} fid   ]
  if {$r} {
    return -code error "Exec error: $fid\n"
  }
  fconfigure $fid -blocking 0
  fconfigure $fid -buffering none
  fconfigure $fid -encoding    binary
  fconfigure $fid -translation binary
  # schedule the completer...
#  chan event $fid readable "Complete_pipe $fid stdout"
#  chan event $erf readable "Complete_pipe $erf error"
#  chan event $fid writable "puts -nonewline \">>?\";chan event $fid writable \"\""
  uplevel set spawn_id $fid
  uplevel {
    if {![info exists timeout]} {
      set timeout 10
    }
  }
  set expecta($fid,didfindeof) 0
  set expecta($fid,eoffound) 0
  set expecta($fid,didtimeout) 0
  set expecta($fid,timeout) 0
  set expecta($fid,time_id) 0
  set expecta($fid,buf) {}
  set expecta($fid,bufcount) 0
  set expecta($fid,before) {}
  set expecta($fid,after) {}
#  puts stdout "returning from spawn $spawn_id"
  return $fid
}
proc exp_log_user { args } {
  global expecta
  foreach arg $args {
    switch $arg {
      -info {return $expecta(log_user) }
      0 - 1 {set expecta(log_user) $arg}
      default {return error "exp_log_user expected: -info|0|1 got $args"}
    }
  }
}
proc Log_exp {m} { 
  global expecta
  frputs #2  m
  if {[info exists expecta(log_user)] && $expecta(log_user)} {
  }
  if {[info exists expecta(log_type)] && \
	  ($expecta(log_user) == 1 || $expecta(log_all)) == 1 } {
    if {$expecta(log_type) == "proc" } {
      $expecta(log_chan) ":expect: $m"
    } else {
      puts $expecta(log_chan) $m
    }
  }  
}
# We expand on the log_file command with the -p flag, i.e. -p proc, where
# 'proc' is a tcl proc which is passed exactly one command, the sting to log.
proc exp_log_file {args } {
  global expecta
  incr gobble 0
  if { $args != "-info" } {
    # What ever else happens we shut down any current logging
    if {[info exists expecta(log_type)] && \
	    $expecta(log_type) != "proc" && \
	    ! $expecta(log_leaveopen) } {
      catch "close $expecta(log_chan)"
    }
    set expecta(log_chan) {}
    catch {unset expecta(log_type)}
  }
  foreach arg $args {
    if {$gobble } {
      switch $gobble {
	1 { 
	  if {[info procs $arg] == "$arg" } {
	    set expecta(log_type) "proc"
	    set expecta(log_chan) $arg
	    incr expecta(log_all) 0
	    return
	  } else {
	    return -code  error "Log_exp expected procedure, got $arg"
	  }
	}
	2 {
	  if { [chan names $arg] == $arg } {
	    set expecta(log_type) "fid"
	    set expecta(log_chan) $arg
	    incr expecta(log_leaveopen) 0
	    break
	  } else {
	    return -code error "$arg is not an open channel"
	  }
	}
      }
      set gobble 0
      continue
    }
    switch -glob $arg {
      -p* {incr gobble }
      -open {incr gobble 2}
      -leaveopen {set expecta(log_leaveopen) 1}
      -a {set expecta(log_all) 1 }
      -noappend {incr noapp}
      -info {incr info_rtn}
      default { 
	set expecta(log_type) "file"
	set expecta(log_chan) \
	    [open $arg [expr {[info exists noapp] ? "w" : "a" }]]
	set expecta(log_leaveopen) 0
      }
    }
  }
  switch $gobble {
    0 {}
    1 {return  -code error "expected proc name but got {} " }
    2 {return  -code error "expected open file id but got {} " }
  }
  incr expecta(log_all) 0
  if {[info exists info_rtn] } {
    if { ! [info exists expecta(log_type)] } {
      return "log closed"
    }
    return [list "logType" $expecta(log_type) \
		"logChan" $expecta(log_chan) \
		"-a" $expecta(log_all) ]
  }
  return $expecta(log_chan)
}

proc exp_send {args} {
  set dest {}
  set raw 0
  set mess {}
  frputs args'
  for {set i 0} {$i < [llength $args]} {incr i} {
    set arg [lindex $args $i]
    switch -exact $arg {
      "--" { break}
      -raw {set raw 1}
      -i   {
	incr i
	if { $i >=  [llength $args] } {
	  return -code error "-i option requires destination"
	}
	set dest [lindex $args $i]
      }
      -null {
	incr i
	if {$i < [llength $args] && [string is digit [lindex $args $i]] } {
	  set count [lindex $args $i]
	} else {
	  set count 1
	}
	for {set ii 0} {$ii < $count} {incr ii} {
	  set mess $mess[format %c 0]
	}
	break
      }
      -break -
      -s     -
      -h    {return -code error "$arg option not supported by send (yet)"}
	default {
	  set mess $arg	
      }
    }
  }
  incr i
  if { $mess == {} && $i < [llength $args]} {
    set mess [lindex $args $i]
  }
  if {$dest == {} } {
    set dest [uplevel 1 set spawn_id]
  }
  Log_exp ":sending [regsub {\r} $mess {\\r}] to $dest"
  frputs SEND mess
  puts -nonewline $dest "$mess"
  flush $dest
}
#
# here we put together the expect pattern list
# There is a before and an after list as well as the expect
# call itself.
#
# Expect patterns have three parts, The pattern, the action,and Flags
#
# Here is a routine to parse the patterns into lists of 3 elements per
#
# Options we recognize: -re -ex(act) -nocase  -indices -notransfer 
# -not (same as notransfer) {-i proc} -gl
# Note that we only do a subset of the -i thing, i.e. work against a 
# specified process, and not the indirect process of the "real" expect.

# An internal note, -gl is dropped after it is used, -i is morfed into
# a pattern that changes the id.  The others are combined...

# At this time we will not allow switching of processs during an expect call.
# I.e. the -i may not be used.  This also leads to the convention that
# the spawn_id used is the one in the global spawn_id when the expect_before
# is called.  Rather to make sense of having more than one process active
# AND to make it completly independent, the first pattern in each expect
# call (i.e. expect, expect_before, and expect_after) should be a -i pattern.
# If such is not found, the pattern will be associated with the value of
# the global spawn_id at the time of the call.  This is more or less compatable
# with expect depending on if you really want to intmix processes or keep them
# completely separate.

# And here is a kick in the head.  The tcl string function does not:
# a) have a -exact option, i.e. it is always 'glob'  and..
# b) return any info on where it found the match.
# So we convert the input stings to RE strings (by escaping the key
# RE characters) and use RE searching for everything.
# 
# This routine MUST be called such that uplevel 2 is the user stack...

proc pars_expect { args } {
  lassign { {} 10 } fid timeoutl
  if {[uplevel 2 info exists spawn_id ]} {
    set fid [uplevel 2 set spawn_id]
  }
  if {[uplevel 2 info exists timeout] } {
    set timeoutl [uplevel 2 set timeout]
  }
  set expect_array {}
  set args [lindex $args 0]
  lassign {0  0  0   0    0 } \
          ex re not ind case
  for {set i 0} {$i < [llength $args]} {incr i} {
    set arg [lindex $args $i]
#    puts "args $args and arg $arg"
    switch -exact $arg {
      full_buffer {incr i}
      -not -
      -notransfer {set not 1}
      -re         {set re 1}
      -ex         {set ex 1}
      -nocase     {set case 1}
      -indices    {set ind  1}

      -i       {
	if { $i != 0} {
	  return -code error "The $arg pattern must be the first pattern."
	}
	incr i
	if {$i < [llength $args]} {
	  set fid [lindex $args $i]
	} else {
	  return -code error "expected process id after $arg"
	}
      }

      -timeout {
	incr i
	if {$i < [llength $args]} {
	  set timeoutl [lindex $args $i]
	  if {! [string is digit $timeoutl]} {
	    return -code error "$arg value is $timeout which is not a number"
	  }
	} else {
	  return -code error "$arg found with no following value"
	}
      }

      -gl    -
      default  {
#	puts "default pattern $arg and re $re"
	if {$arg == "-gl"} {
	  incr i
	  if {$i < [llength $args]} {
	    set $arg [lindex $args $i]
	  } else {
	    return -code error "No pattern after -gl"
	  }
	}
	switch -exact $arg {
	  timeout -
	  null    -
	  default -
	  eof    { ; }
	  default {
	    # If RE, do nothing.
	    # If exact, escape RE chars.
	    # Else change glob specials to RE, escape other RE chars.
	    if { ! $re } {
	      if { $ex } {
		set arg ***=$arg
	      } else {
		# first escape the RE characters
		regsub -all {([^\\])([+^$\(\{.])} $arg {\1\\\2} arg ;
		# change the '?'s to '?.'s	
		regsub -all {([^\\])([\?])} $arg {\1.} arg
		# and the '*'s to '.*'s		   
		regsub -all {([^\\])([\*])} $arg {\1.*} arg
		# and, finally prepend the 'use BRE' inline sequence
		set arg (?b)$arg
	      }
	    }
	  }
	}
	lappend expect_array [list \
				  $arg \
				  [expr {[incr i]< [llength $args] ? \
					     [lindex $args $i] : {} }]\
				  $case $ind $not ]
	lassign {0  0  0   0    0} \
	       ex re not ind case
      }
    }	
  }
  if {[info exists ::expecta($fid,buf)]} {
    return [list $expect_array $timeoutl $fid]
  }
  return -code error "Spawn Id $fid is not open."
}

proc expect_before {args} {
  global expecta
  lassign [pars_expect $args] pat timeout fid
  set expecta($fid,before)  [list $pat $timeout]
}

proc expect_after {args} {
  global expecta
  lassign [pars_expect $args] pat timeout fid
  set expecta($fid,after) [list $pat $timeout]
}

proc expect {args} {
  global expecta
  # lets make this really easy...
  uplevel {global expecta}
  # and
  upvar expect_out expect_out
  
  lassign [pars_expect $args] patr timeo fid
#  puts "$patr $timeo $fid"
  set pat {}
  foreach pattern [list $expecta($fid,before) \
                   [list $patr $timeo] \
		       $expecta($fid,after)] {
#    puts "pattern $pattern"
    if {$pattern != {} } {
      set pat [concat $pat [lindex $pattern 0]]
#      puts "$pat"
      if {[lindex $pattern 1] != {} } {
	# last one wins...
	set to [lindex $pattern 1]
      }
    }
  # So, that was cool, now what...
  }
#  puts "PAT: $pat"
  set expecta($fid,timeout) 0
  set expecta($fid,didtimeout) 0
  set expecta($fid,to) [expr {$to * 1000}]
  set expecta($fid,timeout_id) [after $expecta($fid,to) "dotimeout $fid" ]
  # Plant the timeout id in the uplevel for exp_continue
  uplevel set expect_fid_planted_for_continue $fid
#  puts "timeout in $to secs [info level]"
# The main expect loop....
#
  set buffresh 1
  while { 1 } {
    if {$buffresh } {
      set buffresh 0
      # here is where we do the pattern stuff...
#      puts "the big $pat"
      set t [regsub -all {\n} $expecta($fid,buf) {<n>}]
      set t [regsub -all {\r} $t {<r>}]
      Log_exp "examining: >$t<"

      foreach pats  $pat {
#	puts "then $pats"
	lassign $pats patt whattodo case ind not
#	puts "pat=$patt what=$whattodo case=$case ind=$ind not=$not"
	# first, the match type
	set re 0
	switch -exact $patt {
	  timeout {set re [expr {$expecta($fid,timeout)}] }
	  eof     {set re [expr {$expecta($fid,eoffound)}]}
	  default {
	    set re [expr {$expecta($fid,timeout) || $expecta($fid,eoffound)}]
	  }
	  null    {
	    if {$expecta($fid,buf) == "0"} {
	      set expect_out(buffer) "0"
	      set $expecta($fid,buf) {} 
	      set re 1
	    }
	  }
	  default {
	    # lets make the newlines and returns visable
	    # set t [regsub -all {\n} $expecta($fid,buf) {<n>}]
	    # set t [regsub -all {\r} $t {<r>}]
	    # Log_exp "examining: >$t<"

	    # We could not do all this in the case of an empty buffer
	    # however, we want to match (.*) or (*) in that case to
	    # handle buffer flushing.
	    
	    set doit regexp
	    set ty string
	    if {$ind } {
	      lappend doit "-indices"
	      set ty start
	    }
	    if {$case } {
	      lappend doit "-case"
	    }
	    lappend doit -- $patt $expecta($fid,buf) \
		expect_out(0,$ty)\
		expect_out(1,$ty)\
		expect_out(2,$ty)\
		expect_out(3,$ty)\
		expect_out(4,$ty)\
		expect_out(5,$ty)\
		expect_out(6,$ty)\
		expect_out(7,$ty)\
		expect_out(8,$ty)\
		expect_out(9,$ty)
	    #	      uplevel [list puts "doing uplevel regexp >$doit<" ]
	    set re [uplevel $doit]
	    #	      puts "result is $re"
	    if {$re && $ty == "start"} {
	      # indices are a bit messy in that we also need strings...
	      set expect_out(buffer) [string range $expecta($fid,buf) 0\
					  [lindex $expect_out(0,start) 1]]
	      foreach mc {0 1 2 3 4 5 6 7 8 9} {
		lassign $expect_out($mc,start) first last
		set expect_out($mc,end) $last
		set expect_out($mc,start) $first
		set expect_out($mc,string) \
		    [string range $expect_out(buffer) $first $last]
	      }
	    } elseif {$re} {
	      set end [expr {[string first $expect_out(0,string)\
				  $expecta($fid,buf)] +\
				 [string length $expect_out(0,string)]}]
	      set expect_out(buffer) [string range $expecta($fid,buf) 0 $end-1]
	    }
	    if {$re } {
	      # frputs #2 doit "[array get expect_out] "
	      if {! $not} {
		# here we need to up date the buf
		set expecta($fid,buf) \
		    [string range $expecta($fid,buf) \
			 [string length $expect_out(buffer)] end]
		set expecta($fid,bufcount) [string length $expecta($fid,buf)]
	      }
	    }	    
	  }
	}
	if { $re } {
	 after cancel $expecta($fid,timeout_id)
	  frputs whattodo expect_out(1,string) expect_out(buffer)
	  Log_exp "found : $patt"
	  uplevel $whattodo
	  frputs AFTERWHATTODO expecta($fid,buf)
	  return
	}
      } ; # End of for loop
 #     puts "timeout? $expecta($fid,timeout)"
      if {$expecta($fid,timeout)} {
	# Uh..? are we supposed to ignor these?
	# Unhandled timeout...
	return -code error "Expect error on $fid, unhandled timeout"
      }
      if {$expecta($fid,eoffound)} {
	# Unhandled eof...
	return -code error "Expect error on $fid, unhandled eof"
      }
      # If we are still here AND we found something (re != 0) and
      # There is data left in the buffer, force another go round
      # before waiting for more data... still, we get any data we
      # already have in hand.  This allows multiple passes on a buffer
      # so that, with care, one can wait for the end of the data and
      # then do what is needed all in one call.
      if {[exp_Complete_pipe $fid] != 0 || \
	      ($re && [string length $expecta($fid,buf)] != 0)} {
	  set buffresh 1
      }
    } else {
      chan event $fid readable "exp_Complete_pipe $fid"
#      puts "waiting on $fid or timeout"
      if {[exp_Complete_pipe $fid] == 0 } {
	vwait expecta($fid,event)
      }
      # We catch the following so an Eof will not error out prior to
      # actually sending the event back.
      catch "chan event $fid readable {}"
 #     puts "back"
      set buffresh 1
    }
    set expecta($fid,timeout) $expecta($fid,didtimeout)
    set expecta($fid,eoffound) $expecta($fid,didfindeof)      
  }
}

proc dotimeout { fid } {
  global expecta
#  puts "dotimeout called"
  incr expecta($fid,didtimeout)
  incr expecta($fid,event)
}

# Manage the incomeing pipe (output from the spawned).
# We put the info in a buffer tied to the file id of the spawn (i.e. spawn_id)
# this allows us to handle more than one process...

proc exp_Complete_pipe { fid} {
  global expecta
  if {![info exists expecta($fid,buf)]} {
    frputs PIPECOMPNOBUFFER
    return
  }
  #  Log_exp  "Complete_pipe called on ($fid)"
  set out ""
  set r [catch {read $fid} out ]
  # Should not need this, but...
  #if {$out == ""} {set out \r}
  frputs PIPECOMP fid r out
  incr expecta($fid,event)
  if {$out != ""} {
    # We auto detect UNICODE and translate it.
    # The assumption is that a nul (i.e. binary 0) in the line will
    # give us the hint. (Should this be an option??)
    
    # if {[regsub -all {\x00} $out {} out] != 0} {
    #   frputs FOUNDUNICODE
    # }
    set expecta($fid,buf) $expecta($fid,buf)$out
    #incr expecta($fid,event)
    Log_exp "Read on $fid :$out"
  }
  if {$r || [eof $fid]} {
    incr expecta($fid,didfindeof)
    catch {close $fid}
    Log_exp "EOF found on $fid"
    return 1
  }
  return [string length $out]
}

proc exp_continue {{to 0}} {
  global expecta
#  puts "CONTINUE CALLED [info level]"
  if {$to != "-continue_timer" } {
    set fid [uplevel set expect_fid_planted_for_continue]
    after cancel $expecta($fid,timeout_id)
    set expecta($fid,timeout_id) [after $expecta($fid,to) "dotimeout $fid" ]
  }
  Log_exp "exp continue $expecta($fid,buf)"
  return -code continue
}

proc exp_close { {flag 0} { fid {}}} {
  if {$flag != "-i" } {
    if {$flag == 0 } {
      set fid [uplevel set spawn_id]
    } else {
      return -code error "exp_close expects -i spawn_id, not $flag .."
    }
  }
  Log_exp "Closing $fid"
  catch {set out [read $fid]} dt
  frputs out dt ::expecta($fid,buf)
  catch {close $fid} r
  # clean up...
  # array unset ::expecta $fid,*
  frputs r
}
# no documentation of what this is suppost to do...
# This command delays until a spawned process (or the current process 
# if none is named) terminates.

# exp_wait normally returns a list of four integers. The first integer  
# is the pid of the process that was waited upon. The second integer is  
# the corresponding spawn id. The third integer is -1 if an operating  
# system error occurred, or 0 otherwise. If the third integer was 0, the  
# fourth integer is the status returned by the spawned process. If the  
# third integer was -1, the fourth integer is the value of errno set by  
# the operating system. The global variable errorCode is also set.

proc exp_wait {args} {}

proc exp_pid {{fid {}} args} {
  if {$fid == {} } {
    set fid [uplevel set spawn_id]
  } else if { $fid != "-i" } {
    return -code error "exp_pid expects -i spawn_id, not $fid .."
  } else {
    set fid $args
  } 
  return [pid $fid]
}

proc exp_match_max {args} {}

