# 
# 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

   http://82.171.148.176/Bwise/pcomlbf.tcl

• Most older versions of pcom 'hang' in a bad way on at least recent tcl/tk versions, because the socket isn't noticing end of files, and uses all processor time and after a while all memory including swap space to read empty lines full time into the log window.
• (re) define the (global myport) standard socket and within two file transfer functions the file transfer port numbers to make sure unix/linux doesn't have a problem finding those ports freely available.
• It seems also on later versions (like mentioned above) the file transfer mechanism messes up after an error has occured, though it can be made to work through firewalls (define port as something handy and make sure the connection is built up in the 'right' direction (which pcom tries to figure out) ... Preferably restart after a file transfer error, otherwise a socket remains open, and the file open command makes a sometimes unremovable empty file (as long as that running pcom isn't quit) and the next tranfer might end up in the wrong file. When there is no error, things work fine.
• the two port entries aren't doing something interestingly different currently
• some logging is one-sided or unneatly formatted
• large file tranfer makes the app unresponsive till the end
• First at least one line or command must pass the connection before the fail safe disconnect works (my God...)
• Empty directories and filenames with spaces in then (on windows at least) make the file browsers fail beyond help
• No confirmation for file transfer, just the double-click starts it, and there is also no protection for file overwriting at all, also not when the transfer fails.
• The latest version messes up because the automatic detection of end-of-control-connection and the close buttons message to do the same get in eachothers way and generate an error.
• I noticed that between a linux and windows machine, file transfer when initiated from the linux machine doesn't work in half the cases.
• During the setup of the file transfer socket connection, a short period exists where a agressive (short repetition interval) access to the file transfer server socket could be granted to another party, leaving you either with a security hole for that file, or an overwrite of the file with unknown (possibly bulky) data.

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}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References