# 
# Pcom: a personal communication shell
# by: Theo Verelst ([email protected])
#

# during debug:
#set t [winfo children .]
set t {.f .fl}
foreach i [winfo children .]  {
     if {[winfo toplevel $i] != $i} {
          lappend t $i
     }
}
foreach i $t {destroy $i}
update

set myss -1      ;# my server socket
set rems -1      ;# remote socket
set myip -1      ;# local IP address
set myport 300   ;# default port

set state ready
set allowtcl 1
                      # quite dangerous, a total security loophole...
                      # set to zero when in doubt...
                      # it allows remote command execution
set icanconnect 0

set crdir /
set crpat *
set crdirs {}
set crfiles {}
set cldir /
set clpat *

# I don't think this works anymore..
proc forceclose {{max 30} {from 0} {type sock}} {
    log "forced closed: "
    for {set i 0} {$i <30} {incr i}  {
        set name "$type[expr $from + $i]"
        if {[catch "close $name"] == 0} {
            log " $name"
        }
    }
    log \n
}


proc log {l} {
    if {[winfo exists .tlog]} {
        .tlog insert end $l
        .tlog see end
    } else {
        puts -nonewline "$l"
    }
}

# Incoming lines are parsed based on the first word, the command, 
# and the second 'argument' or the rest of the line, which in some cases 
# gets parsed further.

proc parse_in {in} {
    global state allowtcl
    
 #   set com [lindex $in 0]
    set com [string range $in 0 [expr [string first " " $in] -1] ]
    set rest [string range $in [expr [string first " " $in] +1] end ]
    switch $com \
    {DO_LS} {
        set olddir [pwd]; set dirs {}; set files {}
        set dir [lindex $rest 0]; set pattern [lindex $rest 1]
        if {[catch {cd $dir}] != 0} {
            send "VALUE_LS $dir $pattern [list {non-existent dir} {}]"
            cd $olddir
            log "DO_LS $dir $pattern (Error: non-existent dir)\n"
            return
        }
        puts [pwd]
        foreach i [glob $pattern] {
            if [file exists $i] {
                if [file isdir $i] {
                    lappend dirs $i
                } else {
                    lappend files $i
                }
            }
        }
        send "VALUE_LS $dir $pattern [list $dirs $files]"
        cd $olddir
        log "DO_LS $dir $pattern\n"
    } \
    {DO_TCL} {
        if {$allowtcl != 0} {
            set tcl $rest
            set cr [catch $tcl tclret]
 #         if {$cr == 0} {
 #            if {[info exists tclret] == 0} {set tclret ""}
 #         } else {
 #            set tclret ERROR
 #        }
            log "Tcl executed:\n$tcl\n"
            send "DO_TCLRET $tclret"
        } else {
            log "Tcl command blocked (not allowed):\n$tcl\n"
        }
    } \
    {DO_SETVAR} {
        if {$allowtcl != 0} {
            set tclvar [lindex $rest 0]
            set tclval [lrange $rest 1 end]
            global $tclvar
            eval set $tclvar $tclval
 #         puts $tclvar
            log "Tcl set executed: set $tclvar $tclval\n"
        } else {
            log "Tcl set command blocked (not allowed): set $tclvar $tclval\n"
        }
    } \
    {DO_TCLRET} {
        if {$rest ne ""} {log "Tcl Return value: $rest\n"}
        set state ready
    } \
    {VALUE_LS} {
        global crdir crpat crdirs crfiles
        set crdir   [lindex $rest 0]
        set crpat   [lindex $rest 1]
        set crdirs  [lindex $rest 2]
        set crfiles [lindex $rest 3]
        # puts "$rest\n$crdirs,$crfiles"
        .f.ld del 0 end ; .f.lf del 0 end
        foreach i $crdirs {.f.ld insert end $i}
        foreach i $crfiles {.f.lf insert end $i}
    } \
    {DO_RECFILE} {
        log "(requested: DO_RECFILE $rest)"
        eval receive_file $rest
        send "READY_RECFILE "
        log "READY_RECFILE\n"
    } \
    {DO_SENDFILE} {
        log "(requested: DO_SENDFILE $rest)"
        eval send_file $rest
        send "READY_SENDFILE "
        log "READY_SENDFILE\n"
    } \
    {DO_REQSENDFILE} {
        send "DO_SENDFILE $rest"
        log "DO_SENDFILE $rest\n"
    } \
    {DO_ABORTFILE} {
        catch "close $filess; close $fileso; close $filed"
        log "Aborted file transfer.\n"
    } \
    {DO_CLOSECONTROL} {
        global rems
        disconnect $rems
        set rems -1
        log "Closed control connection.\n"
    } \
    {default} {
        .tcom insert end "REMOTE: $in\n"
        .tcom see end
        set state ready
    }
}

proc serv {sock ip t} {
    global rems remip
    log "client connected, socket $sock, ip adr $ip\n"
    if {$rems != -1} {
        log "client connect attempt while already connected, ignored\n"
        close $sock
        return
    }
    set rems $sock
    set remip $ip
    fileevent $rems readable {
        global rems
        set in [gets $rems]
        parse_in $in
     }
}

proc init {} {
    global myport myip myss

    # figure out ip address before server socket is started
    myip

    # log window
    text .tlog -width 40 -height 4
    pack  .tlog -side bottom -anchor s -expand n -fill both
 
    log "my IP address is $myip.\n"

    # set up a listening socket
    catch {set myss [socket -server serv $myport]}
    if {$myss != -1} {
        log "listening with $myss at port $myport\n"
    } else {
        log "server socket already in use, use active connect.\n"
    }
 
    log "Init OK.\n"
}

proc tserv {sock ip t} {   # simply to figure out IP address
    global ts
    set ts $sock
}

proc myip {{port 302}} {    # Figure out what this machine's IP address is.
    global myip
    set tss [socket -server tserv $port]
    set ts2 [socket [info hostname] $port]
    set myip [lindex [fconfigure $ts2 -sockname] 0]
    close $tss
    close $ts2
    if [info exists ts] {close $ts}
    return $myip
}

proc disconnect {s} {
    close $s
    # set $s -1
    log "disconnected (closed $s).\n"
}

proc connect {{toip {}} {toport {}}} {
    global rems remip myport icanconnect
    if {$rems != -1} {
        log "Connect attempt while already connected: ignored"
        return
        disconnect $rems
        set rems -1
    }
    if {[catch {set rems [socket $remip $myport]}] != 0} {
        set rems -1
        log "Attempt to connect to $remip failed.\n"
        return
    }
    fileevent $rems readable {
        global rems
        set in [gets $rems]
        parse_in $in
    }
    set icanconnect 1  ;# appearently we could initiate a connection with the addressee
}

proc send {{line \n}} {
    global rems
    if {$rems == -1} {return}
    puts $rems $line
    flush $rems
}

proc new_serv_address {} {
    global myss myport rems
    if {$rems != -1} {
        log "Attempt to change server IP address while already connected, ignored\n"
        return
    }
    if {$myss != -1} {
        close $myss
        log "Closed server socket $myss\n"
        set myss -1
    }
    if {[catch {set myss [socket -server serv $myport]}] == 0} {
        global icanconnect
        log "Now listening with $myss at port $myport\n"
        set icanconnect 0
    } else {
        set myss -1
        log "server address already in use, use active connect.\n"
    }
}

# send routines, with the ability to initiate the socket connection 
# from either the send or receive side.
# that is, either one of two connected pcom's can initiate the connection 
# tp transfer a file a certain direction, regardless of which 
# pcom did the file transfer request. (firewall stuff))

proc file_serv_send {s ip t} {
    global filess fileso filed
    set fileso $s
    close $filess        ;# no longer needed
 
     fconfigure $filed -translation binary
     fconfigure $fileso -translation binary
     set n [fcopy $filed $fileso]
     close $filed
     close $fileso
     log ", Ready ($n bytes).\n"
    
}
proc file_serv_receive {s ip t} {
    global filess fileso filed
    set fileso $s
    close $filess        ;# no longer needed
    
    fconfigure $filed -translation binary
    fconfigure $fileso -translation binary
    set n [fcopy $fileso $filed]
    close $fileso
    close $filed
    log ", Ready ($n bytes).\n"
}

proc send_file {localname port {ip {}} } {
    global filess fileport filed fileso
    if {[catch {set filed [open $localname r]}] != 0} {
        log "Unable to open file $localname to send.\n"
        return ERROR
    }
    if {$ip == {}} {
        set fileport $port
        if {[catch {set filess [socket -server file_serv_send $port]}] != 0} {
            log "Unable to open file server socket (port $port).\n"
            return ERROR
        }
        log "Transfering file $localname "
    } else {
        set fileport $port
        if {[catch {set fileso [socket $ip $port]}] != 0} {
            close $filed
            log "Unable to open connection to $ip, port $port for file tranfer.\n"
            return ERROR
        }
        fconfigure $filed -translation binary
        fconfigure $fileso -translation binary
        log "Transfering file $localname "
        set n [fcopy $filed $fileso]
        close $filed
        close $fileso
        log ", Ready ($n bytes).\n"
    }
}

proc receive_file {localname port {ip {}} } {
    global filess fileport filed fileso
    if {[catch {set filed [open $localname w]}] != 0} {
        log "Unable to open file $localname to receive.\n"
        return
    }
    if {$ip == {}} {
        set fileport $port
        if {[catch {set filess [socket -server file_serv_receive $port]}] != 0} {
            log "Unable to open file server socket (port $port).\n"
            return ERROR
        }
        log "Transfering file $localname "
    } else {
        set fileport $port
        if {[catch {set fileso [socket $ip $port]}] != 0} {
            close $filed
            log "Unable to open connection to $ip, port $port for file tranfer.\n"
            return ERROR
        }
        fconfigure $filed -translation binary
        fconfigure $fileso -translation binary
        log "Transfering file $localname "
        set n [fcopy $fileso $filed]
        close $fileso
        close $filed
        log ", Ready ($n bytes).\n"
    }
}

proc do_receive_file {rdir file ldir} {
    global myip remip icanconnect
    set recport 305                      
                              # This could be any free port which is available
    if {$icanconnect == 1} {
        send "DO_SENDFILE [file join $rdir $file] $recport"
        receive_file [file join $ldir $file] $recport $remip
    } else {
        receive_file [file join $ldir $file] $recport
        send "DO_SENDFILE [file join $rdir $file] $recport $myip"      
    }
}

proc do_send_file {ldir file rdir} {
    global myip remip icanconnect
    set recport 305   
                             # to get files through firewalls, use 80 ... (also see above)
    if {$icanconnect == 1} {
        send "DO_RECFILE [file join $rdir $file] $recport"
        send_file [file join $ldir $file] $recport $remip
    } else {
        send_file [file join $ldir $file] $recport
        send "DO_RECFILE [file join $rdir $file] $recport $myip"      
    }
}


proc make_ui {} {
    global remip intext myport
 #   label .lip -textvar myip
 #   pack .lip -side top -anchor n -expand n -fill none
    frame .fb
    pack .fb -side top -anchor n -expand n -fill x
    button .fb.bquit -text Quit -command quit
    pack .fb.bquit -side right -anchor ne -fill none -expand n
    label .fb.lstate -textvar state
    pack .fb.lstate -side left -anchor nw -fill none -expand n
    button .fb.bna -text "New Address" -command new_serv_address
    pack .fb.bna -side left -anchor nw -fill none -expand n
    button .fb.bcl -text "Close Connection" -command \
         {global rems; send "DO_CLOSECONTROL \n"; disconnect $rems; set rems -1 }
    pack .fb.bcl -side left -anchor nw -fill none -expand n
    frame .fcl
    frame .fc1
    frame .fc2
    frame .fc3
    pack .fcl -side top -anchor n -expand n -fill x
    pack .fc1 -side top -anchor n -expand n -fill x
    pack .fc2 -side top -anchor n -expand n -fill x
    pack .fc3 -side top -anchor n -expand n -fill x
    set remip 127.0.0.1
    entry .fc1.eip -textvar remip -width 14
    entry .fc2.eport -textvar myport -width 14
    entry .fcl.elip -textvar myport -width 14
    label .fc1.lip -text "Remote IP address:" -width 15 -anchor e
    label .fc2.lport -text "Port:" -width 15 -anchor e
    label .fcl.llip -text "Local server port" -width 15 -anchor e
    button .fc3.connect -text Connect -command connect
    pack .fcl.llip -side left -expand n -fill none
    pack .fcl.elip -side left -expand n -fill none
    pack .fc1.lip -side left -expand n -fill none
    pack .fc1.eip -side left -expand n -fill none
    pack .fc2.lport -side left -expand n -fill none
    pack .fc2.eport -side left -expand n -fill none
    pack .fc3.connect -side left -expand y -fill x
 
    text .tcom -width 40 -height 4
    entry .ecom -textvar intext
    pack .ecom -side top -anchor n -fill x -expand y
    pack .tcom -side top -anchor n -fill both -expand y
    bind .ecom <Return> {
        send $intext; .tcom insert end "LOCAL: $intext\n";
        .tcom see end
        set intext ""
    }
    make_fileui
}

proc make_fileui {} {
    toplevel .f
    wm title .f "Remote Dir"
    listbox .f.ld; listbox .f.lf
    pack .f.ld .f.lf -side left -expand y -fill both
    entry .f.ed -textvar crdir
    entry .f.ep -textvar crpat
    pack .f.ed .f.ep 
    button .f.bu -text Update -command \
         {global crdir crpat; send "DO_LS $crdir $crpat"}
    button .f.bdu -text Up
    pack .f.bu .f.bdu -fill x
    .f.bdu conf -command { 
        set s [file split $crdir]
        if {[llength $s] > 1} {
            set up [eval file join [lrange $s  0 [expr [llength $s]-2] ] ]
            set crdir $up
        }
        .f.bu invoke
    }
    bind .f.ld <Double-Button-1> {
        global crdir
        set crdir [eval file join $crdir [selection get]]
        .f.bu invoke
    }   
    bind .f.lf <Double-Button-1> {
        do_receive_file $crdir [selection get] $cldir
    }
    
 
 # local file windows
    toplevel .fl
    wm title .fl "Local Dir"
    listbox .fl.ld; listbox .fl.lf
    pack .fl.ld .fl.lf -side left -expand y -fill both
    entry .fl.ed -textvar cldir
    entry .fl.ep -textvar clpat
    pack .fl.ed .fl.ep 
    button .fl.bu -text Update -command \
         {do_local_ls }
    button .fl.bdu -text Up
    pack .fl.bu .fl.bdu -fill x
    .fl.bdu conf -command { 
        set s [file split $cldir]
        if {[llength $s] > 1} {
            set up [eval file join [lrange $s  0 [expr [llength $s]-2] ] ]
            set cldir $up
        }
        .fl.bu invoke
    }
    bind .fl.ld <Double-Button-1> {
        global cldir
        set cldir [eval file join $cldir [selection get]]
        .fl.bu invoke
    }
    bind .fl.lf <Double-Button-1> {
        do_send_file $cldir [selection get] $crdir
    }
}

proc do_local_ls {} {
    global cldir clpat
        set olddir [pwd]; set dirs {}; set files {}
 #      puts [pwd]
        if {[catch "cd $cldir"] != 0} {
            cd $olddir
            log "Local ls: $cldir $pattern (Error: non-existent dir)\n"
        }
 #      puts [pwd]
        foreach i [glob $clpat] {
            if [file exists $i] {
                if [file isdir $i] {
                    lappend dirs $i
                } else {
                    lappend files $i
                }
            }
        }
        .fl.ld del 0 end ; .fl.lf del 0 end
        foreach i $dirs {.fl.ld insert end $i}
        foreach i $files {.fl.lf insert end $i}
        
        cd $olddir
 #      puts "$cldir $clpat {$dirs} {$files}"
}

proc close_all {} {
    global myss rems
    if {$myss != -1} {close $myss; set myss -1}
    if {$rems != -1} {close $rems; set rems -1}
}

proc quit {} {
    close_all
    log "Quit: all sockets closed.\n"
    # this was for certain particular reasons, use main window close to realy quit.
}


#
# main
#

history keep 1000   
                          # I always do this, but it makes not much sense  
# console show      # without this command of course (it seems).
init
make_ui

.pc

40,41d39
<  set xpathset 0
< 
263,266d260
<       if [eof $rems] {
<          disconnect $rems
<        set rems -1
<       }
448,462d441
<    # for Xwindows remote commands
<    button .pc.fc3.xwindows -text Xwindows -command {
<       if {$xpathset == 0} {
<          send {DO_TCL uplevel #0 {append env(PATH) {;c:\cygwin\bin;c:\cygwin\usr\X11R6\bin;}}}
<          global env
<          append env(PATH) {;c:\cygwin\bin;c:\cygwin\usr\X11R6\bin;}
<          exec xterm -fn '-adobe-courier-*-r-*-*-*-140-*-*-*-*-*-*' -rightbar -sb -fg white -bg black -title inez -geom 80x6-91+91 -display localhost:0 &
<          exec xterm -fn '-adobe-courier-*-r-*-*-*-140-*-*-*-*-*-*' -rightbar -sb -fg white -bg black -title inez -geom 80x6-91+423 -display localhost:0 &
<          set  xpathset 1
<       }
<       send {DO_TCL exec xterm -display inez.mshome.net:0.0 -fn -*-courier-*-r-*-*-15-*-*-*-*-*-*-* -bg black -fg lightgreen -sb -rightbar  -title benee -geom 80x5-91+250 &}
<    }
<    button .pc.fc3.peek -text Peek -command {
<       send {DO_TCL pcsend [.pc.tcom get end-5l end]}
<    }
470,471d448
<    pack .pc.fc3.xwindows -side left -expand y -fill x
<    pack .pc.fc3.peek -side left -expand y -fill x
602,608d578
< wm iconify .
< wm iconify .pc.f
< wm iconify .pc.fl
< wm geom .pc +0+543
< 
< update
< catch {.pc.fc3.connect invoke}