File: console.tcl

package info (click to toggle)
magic 7.5.241-1
  • links: PTS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 17,772 kB
  • ctags: 12,301
  • sloc: ansic: 170,465; sh: 10,446; perl: 4,105; lisp: 2,554; tcl: 2,469; makefile: 1,887; cpp: 587; csh: 148; awk: 140
file content (138 lines) | stat: -rwxr-xr-x 4,677 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
#!/usr/bin/tclsh
#
# console.tcl:
#
#  Defines Procedures which should be defined within the console
#  (master) interpreter (i.e., tkcon, if it is executed as a separate
#  interpreter).  Note that this can always be worked around via the
#  "tkcon master" or "tkcon slave" commands, but this method organizes
#  things in a more natural way.

wm geometry . 120x16+150-50

proc gettext {{prompt {}} {response {}}} {

   # Differentiate between console command-line and button execution
   # (Determines whether to prompt before or after execution)
   if {[.text index output] == [.text index end]} {
      ::tkcon::Prompt
      set mode 1
   } else {
      set mode 0
   }

   replaceprompt "?"
   if {$prompt != {}} {
      .text insert end $prompt {stdout}
   }
   if {$response != {}} {
      set result [tkcon congets $response]
   } else {
      set result [tkcon congets]
   }
   tkcon set ::tkcon::OPT(prompt1) "% "
   if {$mode == 0} {
      ::tkcon::Prompt
   } else {
      .text mark set output end
      tkcon console see output	;# adjust view to encompass newline
      update idletasks
   }
   return $result
}

slave alias magic::dialog gettext
slave alias magic::consolegeometry wm geometry .
slave alias magic::consolefocus focus -force .text
slave alias magic::suspendout rename temp_puts puts
slave alias magic::resumeout rename puts temp_puts

# Ensure that destroying the console window queries for saving
# modified layouts rather than forcing an immediate exit.

wm protocol . WM_DELETE_WINDOW {tkcon slave slave magic::quit}

proc temp_puts { args } {
    # null procedure;  output is suspended.
}

proc magiccolor { ch } {
    tkcon slave slave magic::magiccolor $ch
}

proc replaceprompt { ch } {
    tkcon set ::tkcon::OPT(prompt1) "$ch "
    .text delete prompt.last-2c
    .text insert [.text index prompt.last-1c] $ch {prompt}
    .text mark set output [.text index output-1c]
}

# This procedure repaints the magic console to match the magic colormap.
# It's only called if magic is run in 8-bit (PseudoColor) visual mode.
# This is called from inside magic (graphics/grTk1.c).

proc repaintconsole {} {
    puts stdout "Repainting console in magic layout window colors"

# Because the console invokes a slave interpreter, we have to evaluate
# magic command "magiccolor" in the slave interpreter.  Note that all of
# these colors are short names from the ".dstyle6" file.  Long names are
# also acceptable.

    ::set yellow [interp eval $::tkcon::OPT(exec) magiccolor yellow2]
    ::set black [interp eval $::tkcon::OPT(exec) magiccolor black]
    ::set gray [interp eval $::tkcon::OPT(exec) magiccolor gray2]
    ::set green [interp eval $::tkcon::OPT(exec) magiccolor green3]
    ::set purple [interp eval $::tkcon::OPT(exec) magiccolor purple1]
    ::set border [interp eval $::tkcon::OPT(exec) magiccolor window_border]
    ::set blue [interp eval $::tkcon::OPT(exec) magiccolor blue2]
    ::set red [interp eval $::tkcon::OPT(exec) magiccolor red3]
    ::set bgcolor [interp eval $::tkcon::OPT(exec) magiccolor no_color_at_all]

    tkcon set ::tkcon::COLOR(bg) $bgcolor
    tkcon set ::tkcon::COLOR(blink) $yellow
    tkcon set ::tkcon::COLOR(cursor) $black
    tkcon set ::tkcon::COLOR(disabled) $gray
    tkcon set ::tkcon::COLOR(proc) $green
    tkcon set ::tkcon::COLOR(var) $purple
    tkcon set ::tkcon::COLOR(prompt) $border
    tkcon set ::tkcon::COLOR(stdin) $black
    tkcon set ::tkcon::COLOR(stdout) $blue
    tkcon set ::tkcon::COLOR(stderr) $red

    .text configure -background $bgcolor
    .text configure -foreground $black
    .text configure -insertbackground $black

    .text tag configure var -background  $bgcolor
    .text tag configure blink -background  $bgcolor
    .text tag configure find -background  $bgcolor
    .text tag configure stdout -background  $bgcolor
    .text tag configure stderr -background  $bgcolor
    .text tag configure proc -background  $bgcolor
    .text tag configure prompt -background  $bgcolor

    .text tag configure var -foreground $purple
    .text tag configure blink -foreground $yellow
    .text tag configure find -foreground $yellow
    .text tag configure stdout -foreground $blue
    .text tag configure stderr -foreground $red
    .text tag configure proc -foreground $green
    .text tag configure prompt -foreground $border

    .sy configure -background $bgcolor
}

# Rewrite the ::tkcon::New procedure so that it does not attempt to
# load a second version of magic into the interpreter, which is fatal.

rename ::tkcon::New ::tkcon::NewConsole

proc ::tkcon::New {} {
   global argv0 argc argv

   set argc 1 
   list set argv $argv0   
   ::tkcon::NewConsole 
}