[Theo Verelst] I'm not sure I did a page on [pcom] already (on second reading it seems not), it is a not so large program I did when I had nothing else then some general use networked computers to work on, where I wanted to exchange files and later on chat, maybe remotely execute commands, and keep it simple and a bit reliable. ---- Here is the source code, it's suitable for pretty anchient tcl/tk versions, and does nothing all too freaky, I guess. # # Pcom: a personal communication shell # by: Theo Verelst (theover@yahoo.com) # # 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 != ""} {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 { 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 { global crdir set crdir [eval file join $crdir [selection get]] .f.bu invoke } bind .f.lf { 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 { global cldir set cldir [eval file join $cldir [selection get]] .fl.bu invoke } bind .fl.lf { 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 ---- The program works fine enough, but doesn't get my 'free of bugs' approval symbol: it hangs when file transfer fails for some reason, and Quit is just to close all sockets, and merely requires a new connection or new address (also when it is the same) to make the program work again. Hangup errors, which are not generated normally except by transfer errors for network reasons can make history become very (I mean like hundreds of megs) big, and cpu time all eaten waiting for a non active connection. '''NOTE WELL:''' ''File transfer works without any asking for confirmation by double clicking files either locally or remotely, and file are 'overwritten' without confirmation, too '' !!! You can start two copies of the program by double clicking on the program tcl file twice (or what your os of choice prescribes), give them address 'localhost' or '127.0.0.1' or your machines IP address, will note that one complains that the default port 300 is taken already as serving port on that machine, press that ones' connect button, to get connected. Once connected, which is logged in the bottom window, typing in the one line entry and pressing return will copy that line to the other end and show up in the middle window preceded by 'remote: '. Each pcom has a '''local''' and '''remote''' file window, which show files as it seems logical, use the '''update''' button to refresh the most left directory list and the middle files list box in either file window. NOtice that through the connection, remote files show up, and can be downloaded by FIRST choosing the right directory with the local window. Double clicking in the left list changes directory, the up button does what its name suggests and an update. When double clicking a file (the middle or right list in the file windows) it gets transfered straight away, either from the local machine to the remote machine, or vice versa. Where it is double clicked, it is taken from. I got around using this again because I (positively so) could deal with a local area network, where it is simply the easiest way to get message and som efiles over the net without special or brand specific tools like talk ftp, irc/im remote shells or what else. I wanted to set up a camera and audio connection, and use windows media encoder because it happens to support the equipment at hand, and it is good to have some communication and way to download some things before that works as a good communication link. No windows file sharing or any speical services are needed to make pcom work.