source: tol/toltcl/library/tolsh.tcl @ 25987e3

1941-docker-image-to-testdevel
Last change on this file since 25987e3 was 25987e3, checked in by Jorge Pérez <josp.jorge@…>, 11 years ago

comentamos una traza de depuracion

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@6923 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 17.6 KB
Line 
1#!/usr/bin/env tclsh
2
3###############################################################################
4#
5# tolsh.tcl --
6#
7###############################################################################
8
9package provide TolshApp 3.2
10
11###############################################################################
12#
13#  Tol_HciWriter --
14#
15#  This file will be invoked by TOL if HCI output is enabled
16#
17###############################################################################
18proc Tol_HciWriter { msg } {
19  puts [string trim $msg]
20}
21
22###############################################################################
23#
24#  namespace tolsh -- encapsulate tolsh functionality
25#
26###############################################################################
27namespace eval ::tolsh {
28  variable options
29
30  # By default load initLibrary
31  #
32  set options(lang)    ""
33  set options(initlib) 1
34  set options(iniproject) 1
35  set options(defaultpackages) 1
36  set options(compile) ""
37  set options(vmode)   ""
38  set options(out,enabled) no
39  set options(runmode) ""
40  set options(tolversion) ""
41}
42
43###############################################################################
44#
45#  getoptions -- process the command line
46#
47#  The command line accepted by tolsh is:
48#
49#    -i       --> do not include initLibrary
50#    -np      --> do not load _iniproject.tol
51#    -c"..."  --> compile a tol expression
52#    -c "..." --> compile a tol expression
53#    -v?A?    --> enable all output
54#    -vE      --> enable error output
55#    -vS      --> enable system output
56#    -vU      --> enable user output
57#    -vT      --> enable trace output
58#    -m?A?    --> disable all output
59#    -mE      --> disable error output
60#    -mS      --> disable system output
61#    -mU      --> disable user output
62#    -mT      --> disable trace output
63#    -d       --> start in dialog mode
64#    -e?n?    --> use english language
65#    -s?p?    --> use spanish language
66#    -tolversion ver --> specify an strict tol version to start with
67#    -server [port]  --> start tol as a server tolsvc.<pid>.log will be the log
68#             [port] is the port number where the serve will be listening.
69#
70#  Any other value will be considered a file to compile
71#
72#  Arguments:
73#
74###############################################################################
75proc ::tolsh::getoptions { cmdline } {
76  variable options
77
78  logtmp "entering ::tolsh::getoptions $cmdline"
79
80  # cmdline could be a bad list so the next sentence could fail.
81  # try to test it in front of bugs situations.
82  set num [llength $cmdline]
83  set delayed_msg ""
84  set i 0
85  while {$i < $num} {
86    logtmp "set item [lindex $cmdline $i]"
87    set item [lindex $cmdline $i]
88    if {[string index $item 0] eq "-"} {
89      set opt [string range $item 1 end]
90      if {$opt eq "e" || $opt eq "en"} {
91        set options(lang) "en"
92      } elseif {$opt eq "s" || $opt eq "sp"} {
93        set options(lang) "es"
94      } elseif {$opt eq "i"} {
95        # initLibrary should not be loaded
96        #
97        set options(initlib) 0
98      } elseif {$opt eq "ndp"} {
99        set options(defaultpackages) 0
100      }  elseif {$opt eq "np"} {
101        set options(iniproject) 0
102      } elseif {[string index $opt 0] eq "c"} {
103        if {[string length $opt]>1} {
104          # The tol expression is part of the option
105          #
106          set expr [string range $opt 1 end]
107        } else {
108          # Next argument is the expression to compile
109          #
110          incr i
111          set expr [lindex $cmdline $i]
112        }
113        # Put expr in the list of "things" to compile
114        #
115        lappend options(compile) [list expr $expr]
116      } elseif {[string index $opt 0] eq "v"} {
117        if {[regexp {^[A|S|U|T|E|W]*$} [string range $opt 1 end] mode]} {
118          if {$mode eq ""} {
119            set mode A
120          }
121          if {[regexp {[A|S]} $mode]} {
122            set options(out,enabled) yes
123          }
124          append options(vmode) "v$mode "
125        } else {
126          append delayed_msg "\nignoring unknown verbose mode: '$opt'"
127        }
128      } elseif {[string index $opt 0] eq "m"} {
129        if {[regexp {^[A|S|U|T|E|W]*$} [string range $opt 1 end] mode]} {
130          if {$mode eq ""} {
131            set mode A
132          }
133          if {[regexp {[A|S]} $mode]} {
134            set options(out,enabled) no
135          }
136          append options(vmode) "m$mode "
137        } else {
138          append delayed_msg "\nignoring unknown mute mode: '$opt'"
139        }
140      } elseif {$opt eq "d"}  {
141        if {$options(runmode) ne "" && $options(runmode) ne "interactive"} {
142          puts "Replacing previous run mode '$options(runmode)' with 'interactive'"
143        }
144        set options(runmode) "interactive"
145      } elseif {$opt eq "tolversion"} {
146        incr i
147        set options(tolversion) [lindex $cmdline $i]
148      } elseif {$opt eq "server"} {
149        # check if next argument is the port number
150        set port [lindex $cmdline [expr {$i+1}]]
151        if {[string is integer $port]} {
152          # $i+1 is an integer, should be considered as a port number
153          incr i
154          if {$port <= 0} {
155            puts "Could not start as a server: invalid port number '${port}'"
156            exit
157          }
158          if {$options(runmode) ne "" && $options(runmode) ne "server"} {
159            puts "Replacing previous run mode '$options(runmode)' with 'server'"
160          }
161          set options(runmode) "server"
162          set options(server,port) $port
163        } else {
164          puts "Could not start as a server: invalid port number '${port}'"
165          exit
166        }
167      } elseif {$opt eq "slave"} {
168        # the next argument is the port number
169        set options(server,port) [lindex $cmdline [expr {$i+1}]]
170        incr i
171        if {$options(runmode) ne "" && $options(runmode) ne "slave"} {
172          puts "Replacing previous run mode '$options(runmode)' with 'slave'"
173        }
174        set options(runmode) "slave"
175      } elseif {$opt eq "shared"} {
176        # the next argument is the port number
177        set options(shared,port) [lindex $cmdline [expr {$i+1}]]
178        incr i
179        if {$options(runmode) ne "" && $options(runmode) ne "shared"} {
180          puts "Replacing previous run mode '$options(runmode)' with 'shared'"
181        }
182        set options(runmode) "shared"
183      }  elseif {$opt eq "shport"} {
184        # the next argument is the port number
185        set options(shared,port) [lindex $cmdline [expr {$i+1}]]
186        incr i
187      } else {
188        append delayed_msg "\nignoring unknown option: '$item'"
189      }
190    } else {
191      # Consider this option as a tol file to compile.
192      #
193      if {![file exists $item] || ![file readable $item]} {
194        puts "file $item does not exist or is not readable"
195      } else {
196        lappend options(compile) [list file $item]
197      }
198    }
199    incr i
200  }
201  if {$delayed_msg ne ""} {
202    std $delayed_msg
203  }
204}
205
206###############################################################################
207#
208#  something_to_compile -- tell us if there is something to do
209#
210#  Depending on the command line processing some tol expression or
211#  files needs to be compiled. All this is stored in options(compile)
212#
213#  Return:
214#
215#    true value if there is something to compile in $options(compile)
216#    false if $options(compile) is empty
217#
218###############################################################################
219proc ::tolsh::something_to_compile { } {
220  variable options
221
222  llength $options(compile)
223}
224
225###############################################################################
226#
227#  show_usage -- show how to invoke tolsh
228#
229#  This proc print into stdout a message that list the valid options accepted.
230#
231###############################################################################
232proc ::tolsh::show_usage { } {
233  puts "[get_app_name] \[options] filename ...\noptions:"
234  puts {
235    -i file  --> include a file but not initLibrary
236    -np      --> do not load _iniproject.tol
237    -c "..." --> compile a tol expression
238    -v?A?    --> enable all output
239    -vE      --> enable error output
240    -vS      --> enable standard output
241    -vU      --> enable user output
242    -vT      --> enable trace output
243    -m?A?    --> disable all output
244    -mE      --> disable error output
245    -mS      --> disable standard output
246    -mU      --> disable user output
247    -mT      --> disable trace output
248    -d       --> start in dialog mode
249    -e?n?    --> use english language
250    -s?p?    --> use spanish language
251    -tolversion --> specify an strict tol version to start with
252    -server [port] --> start tol as a server tolsvc.<pid>.log will be the log
253            [port] is the port number where the serve will be listening.
254 
255  Multiple verbose mode is accepted in one option, for instance,
256
257    -vUE
258  }
259}
260
261###############################################################################
262#
263#  getArgv0 -- return the name of the app
264#
265###############################################################################
266proc ::tolsh::get_app_name {} {
267    global argv0
268
269    set name [file tail $argv0]
270    return [file rootname $name]
271}
272
273###############################################################################
274#
275#  append_message -- save a message
276#
277###############################################################################
278proc ::tolsh::std { msg } {
279  variable options
280
281  if {$options(out,enabled)} {
282    puts $msg
283  }
284}
285
286#puts "starkit = [namespace exist ::starkit]"
287#puts "topdir = [file dir $starkit::topdir]"
288#puts "info script = [info script]"
289#puts "starkit::startup = [starkit::startup]"
290#puts "[ info commands starkit::* ]"
291#puts "argv0 = $argv0"
292
293proc ::tolsh::setup_pkg { pkg } {
294  #puts ":tolsh::setup_pkg $pkg [namespace exist ::starkit] "
295  if {[lsearch [package names] $pkg]==-1} {
296    if {[namespace exist ::starkit]} {
297      set bindir [file dir $starkit::topdir]
298      set libdir [file join $bindir .. lib]
299      set pkg_dirs [glob -nocomplain -dir $libdir ${pkg}*]
300      if {[llength $pkg_dirs]} {
301        lappend ::auto_path [file normalize $libdir]
302      } elseif { $::tcl_platform(platform) eq "unix" } {
303          set activeTcl "/opt/ActiveTcl-8.4/lib"
304          if { [ file exists $activeTcl ] &&
305               [ lsearch $::auto_path $activeTcl ] == -1 } {
306            lappend ::auto_path $activeTcl
307          }
308          if { [ lsearch $::auto_path "/usr/lib" ] == -1 } {
309            lappend ::auto_path "/usr/lib"
310          }
311      } else {
312        set tclsh [auto_execok tclsh]
313        if {![catch {
314          exec echo puts {$::auto_path} | $tclsh
315        } ext_auto_path]} {
316          foreach p $ext_auto_path {
317            if {[lsearch $::auto_path $p]==-1} {
318              lappend ::auto_path $p
319            }
320          }
321        }
322      }
323      tclPkgUnknown ${pkg}+1 ""
324    } else {
325      set pkg_dev_dir [file normalize [file join .. $pkg]]
326      if {[file exists $pkg_dev_dir] && [file isdir $pkg_dev_dir]} {
327        lappend ::auto_path $pkg_dev_dir
328      }
329    }
330  }
331}
332
333###############################################################################
334#
335#  setup_autopath --
336#
337#  Set auto_path in order to find correctly the following packages:
338#
339#    - toltcl
340#    - rmtps_client
341#
342###############################################################################
343proc ::tolsh::setup_autopath { } {
344  logtmp "entering ::tolsh::setup_autopath"
345
346  setup_pkg toltcl
347  setup_pkg tolcomm
348  setup_pkg tlogger
349  setup_pkg tequila
350  setup_pkg tequilas
351
352  logtmp "auto_path = $::auto_path"
353  logtmp "leaving ::tolsh::setup_autopath" 
354}
355
356proc GetHomeDir { } {
357  global env
358  # Check if we're using windows
359  if { $::tcl_platform(platform) eq "windows" } {
360    package require registry 1.0
361    set key1 {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders}
362    set key2 {Personal}
363    set env_home [ registry get $key1 $key2 ]
364    if {[string match %USERPROFILE%* $env_home]} {
365      set env_home [string replace $env_home 0 12 $env(USERPROFILE)]
366    }
367  } else {
368    set env_home $env(HOME)
369  }
370  return $env_home
371}
372
373###############################################################################
374#
375#  main -- entry point for tolsh application
376#
377###############################################################################
378proc ::tolsh::run { cmdline } {
379  variable options
380
381  #logtmp "user : [ exec whoami ]"
382  logtmp "entering run with cmdline = $cmdline"
383  # Process command line options
384  #
385  getoptions $cmdline
386  logtmp "options(compile): $options(compile)"
387  logtmp "options(runmode): $options(runmode)"
388  if {![something_to_compile] && ($options(runmode) eq "")} {
389    show_usage
390    return
391  }
392 
393  logtmp "pase getoptions"
394
395  # Ensure Toltcl is found
396  #
397  setup_autopath
398
399  # Load Toltcl (+tol) and initLibrary if required
400  #
401  if {$options(runmode) != "server" && $options(runmode) != "shared"} {
402    package require -exact Toltcl 3.2
403    #puts "tol::initkernel $options(lang) $options(vmode)"
404    tol::initkernel $options(lang) $options(vmode)
405
406    if {$options(initlib)} {
407      tol::initlibrary -initproject $options(iniproject) \
408          -defaultpackages $options(defaultpackages)
409    }
410    # why should I do that?
411    if { $options(lang) ne "" } {
412      ::tol::language $options(lang)
413    }
414    set appdata [string trim \
415               [lindex [::tol::info var [list Text TolAppDataPath]] 2] \"]
416    logtmp "appdata = $appdata"
417  }
418
419  set tolcomm_dir [file join [GetHomeDir] ".tol" "tolcomm"]
420  file mkdir $tolcomm_dir
421
422  # load rmtps_client and tolclient if required
423  #
424  if {$options(runmode) != "server" && $options(runmode) != "shared"} {
425 
426    if {[catch {package require rmtps_client} msg]} {
427      std "could not load rmtps_client: $msg"
428    } else {
429      ::rmtps_client::init [file join $tolcomm_dir "rmtps_client.log"]
430      if {[catch rmtps_client::define_TOLAPI msg]} {
431        std "could not load tol code for rmtps_client: $msg"
432      }
433    }
434 
435    if {[catch {package require tolclient} msg]} {
436      std "could not load tolclient: $msg"
437    } else {
438      ::tolclient::init [file join $tolcomm_dir "tolclient.log"]
439      if {[catch ::tolclient::define_TOLAPI msg]} {
440        std "could not load tol code for rmtps_client: $msg"
441      }
442    }
443   
444  }
445
446  # Compile expression and tol file provided in the command line if required
447  #
448  if {$options(runmode) != "server" && $options(runmode) != "shared" \
449                                    && $options(runmode) != "slave" } {
450
451    foreach item $options(compile) {
452      if {[lindex $item 0] eq "expr"} {
453        tol::console eval [lindex $item 1]
454      } elseif {[lindex $item 0] eq "file"} {
455        tol::include [lindex $item 1]
456      }
457    }
458
459  }
460 
461  if {$options(runmode) eq "interactive"} {
462    # assign our event handler for stdin
463    fileevent stdin readable ::tolsh::stdin_handler
464    # send a startup message and initial prompt
465    puts stdout "TOL interactive shell activated..."
466    console_prompt
467    # enter the tcl event loop
468    vwait __forever__
469   
470  } elseif {$options(runmode) eq "server"} {
471    #puts "runmode=server"
472    run_as_server $tolcomm_dir
473   
474  } elseif {$options(runmode) eq "shared"} {
475    #puts "runmode=shared"
476    run_as_shared $tolcomm_dir
477 
478  } elseif {$options(runmode) eq "slave"} {
479    #puts "runmode=slave"
480    run_as_slave $tolcomm_dir   
481  }
482}
483
484proc ::tolsh::run_as_server {tolcomm_dir} {
485  variable options
486  package require tolserver
487
488  set shared_port [ clone ]
489  tolserver::start -port $options(server,port) \
490    -shport $shared_port \
491    -logfile [file join $tolcomm_dir "tolserver.log"] \
492    -compile $options(compile)
493  vwait __forever__
494}   
495
496proc ::tolsh::find_shared_port { port } {
497  puts "::tolsh::find_shared_port $port"
498  set i 0
499  while { $i < 100 } {
500    if { [ catch { socket localhost $port } fd ] } {
501      puts "find_shared_port OK = $port"
502      return $port
503    }
504    incr port
505    incr i
506  }
507  puts "find_shared_port FAIL!"
508  return 0
509}
510
511proc ::tolsh::clone {} {
512  variable options
513
514  puts "::tolsh::clone"
515  set tolsh [list [info nameofexecutable] ]
516  if { $starkit::tolsh_mode ne "starpack" } {
517    lappend tolsh $::argv0
518  }
519  set shared_port [ find_shared_port 20458 ]
520  if { !$shared_port } {
521    puts "::tolsh::clone: could not find a valid port for shared data"
522    exit
523  }
524  eval exec $tolsh -shared $shared_port &
525  after 5000            ;# wait for data sharing are created by 'shared'
526  puts "exec slave"
527  eval exec $tolsh -slave $options(server,port) -shport $shared_port &
528  return $shared_port
529}
530
531proc ::tolsh::run_as_shared { tolcomm_dir } {
532  package require tolshared
533  variable options
534
535  tolshared::start $options(shared,port) $tolcomm_dir
536}   
537
538proc ::tolsh::run_as_slave { tolcomm_dir } {
539  variable options
540  package require tolslave
541
542  tolslave::start -port $options(server,port) -shport $options(shared,port) \
543    -logfile [file join $tolcomm_dir "tolslave.log"]
544  vwait __forever__
545}   
546
547proc ::tolsh::console_cmd { cmd } {
548  if {$cmd eq "END" || $cmd eq "QUIT" || $cmd eq "EXIT"} {
549    exit
550  } else {
551    puts stdout "unknown console command: '$cmd'"
552  }
553}
554
555proc ::tolsh::console_eval { tol_stms } {
556  set con_objs0 [tol::console stack list]
557  tol::console eval $tol_stms
558  set con_objs1 [tol::console stack list]
559  if {[llength $con_objs1]>[llength $con_objs0]} {
560    puts stdout [lindex [lindex $con_objs1 end] 2]
561  }
562}
563
564proc ::tolsh::console_prompt {} {
565    puts -nonewline stdout \
566        "[clock format [clock seconds] -format %H:%M:%S] TOL> "
567    flush stdout
568}
569
570proc ::tolsh::stdin_handler {} {
571  # get the data from stdin
572  #
573  gets stdin data
574  if {[string index $data 0] eq "\\"} {
575    console_cmd [string toupper [string range $data 1 end]]
576  } else {
577    console_eval $data
578  }
579  # return a new pseudo-prompt
580  console_prompt
581  return
582}
583
584proc logtmp { msg } {
585  return
586  set user $::tcl_platform(user)
587  set fd [ open "/tmp/tolsh.${user}.log" a ]
588  puts $fd $msg
589  flush $fd
590  close $fd
591}
592
593#puts "voy ::tolsh::run $argv"
594::tolsh::run $::argv
595exit
Note: See TracBrowser for help on using the repository browser.