Version 15 of PCOM one-to-one instant messaging and file transfer

Updated 2003-11-12 14:37:25

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 ancient tcl/tk versions, and does nothing all too freaky, I guess.

 # 
 # 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 != ""} {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

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.


TV (16 jun 03) I just pasted the code myself and found out that in certain conditions errors were 'thrown' because I used comments symbols right after a variable assignment statement. I think that is corrected now.

While I was thinking, it occured to me it may be a good idea to have a Secure code method thinking sort of like how one can easily oversee wether some code is guaranteed not to mess up a system for sure within reasonable limits.


TV On how to find my own IP address It was noted that myip, the function which at initialisation time lists the local ip address in the log window, can be wrong. I thus far had no problem with it, but now I found than linux on a local network which I bridge to the internet indeed it doesn't work. And even that user permissions can be such that opening a server socket is not permitted at all, which does not overall make it possible to run pcom as long as the other side can, but it does throw an error.

Also, when the connection is uncommonly broken, for instance when one parties station slips into standby, certain errors make a long list of 'Remote' appear, which eventually eats up all memory and processor cycles...

I've looked into it earlier (I made it years ago) and think it could be solved by catching eof or socket error condition, which is possible from a certain tcl version onward. Or some checking, I'll see, I remember I didn't want to change the protocol, which I sort of demand to be able to send anything, even empty lines, without much processing.

TV (13 oct 2003) Due to unknown reasons I found there are some unniceties/plain errors in the code, and I make an newer version which some people might find handy to play with. It allows only connections from other pcoms (or othe programs using its protocol) which originate from a local network (IP address starting with 192.168 as it is programmed now), and simply rejects others with a log message, which is not just luxury on a constant on internet connection, see the 'serv' function. Also this version opens windows under the path

   .pc

which makes it easier to load into another application, such as bwise, with which it currently (as I last time checked) has no namespace clashes, that is: the global namespaces has no overlap (corrected 'connect' proc to pcconnect, oct 14 03). When nothing goes wrong with the file transfer scokets, it would seem the 'hanging' problem when the other parties disappears without 'close' notice, is solved, and pcom will simply log the other end has closed the connection. I tried it on linux and windows, the only issue being that starting file transfer on the linux side with a windows pcom on the other end based on my self compiled cygwin/X+windows version having its windows on the linux machine generates some errors. Will look into.

'Pcom local' can be downloaded here:

   http://195.241.128.75/Bwise/pcomlbf.tcl

Pcom can also be used for remote control and remote session management issues, like starting and killing applications, see remote execution using tcl and Pcom.

Known bugs/'issues':

  • 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
  • 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.

One cool day, I'll tell 'm all what information technology guys over a mere few decades were able to mess up in a few decades, and in how many shades of socket-shadow... Progress, yeah right!

Please add you own bug reports/comments here or elsewhere


Category Internet | Category Application | Category GUI