Diff of /tclreadlineSetup.tcl.in [000000] .. [758b0c]  Maximize  Restore

Switch to unified view

a b/tclreadlineSetup.tcl.in
1
#!/usr/local/bin/tclsh
2
#
3
# FILE: "/home/joze/src/tclreadline/tclreadlineSetup.tcl"
4
# LAST MODIFIED: "Sun Feb 28 17:43:42 1999 (joze)"
5
# (C) 1998, 1999 by Johannes Zellner
6
# Johannes.Zellner@physik.uni-karlsruhe.de
7
# $Id$
8
# ---
9
#
10
# tclreadline -- gnu readline for tcl
11
# Copyright (C) 1999  Johannes Zellner
12
#
13
# This program is free software; you can redistribute it and/or
14
# modify it under the terms of the GNU General Public License
15
# as published by the Free Software Foundation; either version 2
16
# of the License, or (at your option) any later version.
17
#
18
# This program is distributed in the hope that it will be useful,
19
# but WITHOUT ANY WARRANTY; without even the implied warranty of
20
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21
# GNU General Public License for more details.
22
#
23
# You should have received a copy of the GNU General Public License
24
# along with this program; if not, write to the Free Software
25
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
26
#
27
# Johannes.Zellner@physik.uni-karlsruhe.de
28
# http://krisal.physik.uni-karlsruhe.de/~joze
29
#
30
# ================================================================== 
31
32
package provide tclreadline @TCLREADLINE_VERSION@
33
34
proc unknown args {
35
36
    global auto_noexec auto_noload env unknown_pending tcl_interactive
37
    global errorCode errorInfo
38
39
    # Save the values of errorCode and errorInfo variables, since they
40
    # may get modified if caught errors occur below.  The variables will
41
    # be restored just before re-executing the missing command.
42
43
    set savedErrorCode $errorCode
44
    set savedErrorInfo $errorInfo
45
    set name [lindex $args 0]
46
    if ![info exists auto_noload] {
47
        #
48
        # Make sure we're not trying to load the same proc twice.
49
        #
50
        if [info exists unknown_pending($name)] {
51
            return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
52
        }
53
        set unknown_pending($name) pending;
54
        set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
55
        unset unknown_pending($name);
56
        if {$ret != 0} {
57
            return -code $ret -errorcode $errorCode \
58
                "error while autoloading \"$name\": $msg"
59
        }
60
        if ![array size unknown_pending] {
61
            unset unknown_pending
62
        }
63
        if $msg {
64
            set errorCode $savedErrorCode
65
            set errorInfo $savedErrorInfo
66
            set code [catch {uplevel 1 $args} msg]
67
            if {$code ==  1} {
68
                #
69
                # Strip the last five lines off the error stack (they're
70
                # from the "uplevel" command).
71
                #
72
73
                set new [split $errorInfo \n]
74
                set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
75
                return -code error -errorcode $errorCode \
76
                        -errorinfo $new $msg
77
            } else {
78
                return -code $code $msg
79
            }
80
        }
81
    }
82
83
    # REMOVED THE [info script] TEST (joze, SEP 98)
84
    if {([info level] == 1) \
85
            && [info exists tcl_interactive] && $tcl_interactive} {
86
        if ![info exists auto_noexec] {
87
            set new [auto_execok $name]
88
            if {$new != ""} {
89
                set errorCode $savedErrorCode
90
                set errorInfo $savedErrorInfo
91
                set redir ""
92
                if {[info commands console] == ""} {
93
                    set redir ">&@stdout <@stdin"
94
                }
95
                # LOOK FOR GLOB STUFF IN $ARGS (joze, SEP 98)
96
                return [uplevel eval exec $redir $new \
97
                    [::tclreadline::Glob [lrange $args 1 end]]]
98
            }
99
        }
100
        set errorCode $savedErrorCode
101
        set errorInfo $savedErrorInfo
102
        if {$name == "!!"} {
103
            set newcmd [history event]
104
        } elseif {[regexp {^!(.+)$} $name dummy event]} {
105
            set newcmd [history event $event]
106
        } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
107
            set newcmd [history event -1]
108
            catch {regsub -all -- $old $newcmd $new newcmd}
109
        }
110
        if [info exists newcmd] {
111
            tclLog $newcmd
112
            history change $newcmd 0
113
            return [uplevel $newcmd]
114
        }
115
116
        set ret [catch {set cmds [info commands $name*]} msg]
117
        if {[string compare $name "::"] == 0} {
118
            set name ""
119
        }
120
        if {$ret != 0} {
121
            return -code $ret -errorcode $errorCode \
122
                "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
123
        }
124
        if {[llength $cmds] == 1} {
125
            return [uplevel [lreplace $args 0 0 $cmds]]
126
        }
127
        if {[llength $cmds] != 0} {
128
            if {$name == ""} {
129
                return -code error "empty command name \"\""
130
            } else {
131
                return -code error \
132
                        "ambiguous command name \"$name\": [lsort $cmds]"
133
            }
134
        }
135
    }
136
    return -code error "invalid command name \"$name\""
137
}
138
139
namespace eval tclreadline:: {
140
    namespace export Setup Glob Loop InitCmds InitTclCmds InitTkCmds Print
141
}
142
143
144
proc ::tclreadline::Setup {} {
145
146
147
    uplevel #0 {
148
149
        if {[info commands ::tclreadline::readline] == ""} {
150
            ::tclreadline::Init
151
        }
152
153
        if {[catch {set a [::tclreadline::prompt1]}] \
154
            && [info nameofexecutable] != ""} {
155
156
            namespace eval ::tclreadline {
157
                variable prompt_string
158
                set base [file tail [info nameofexecutable]]
159
160
                if {$base == "tclsh" && [info exists tcl_version]} {
161
                    set prompt_string \
162
                        "\[0;91m$base$tcl_version\[0m"
163
                } elseif {$base == "wish" && [info exists tk_version]} {
164
                    set prompt_string "\[0;94m$base$tk_version\[0m"
165
                } else {
166
                    set prompt_string "\[0;91m$base\[0m"
167
                }
168
169
            }
170
171
            proc ::tclreadline::prompt1 {} {
172
                variable prompt_string
173
                global env
174
                set pwd [pwd]
175
176
                if [info exists env(HOME)] {
177
                    regsub $env(HOME) $pwd "~" pwd
178
                }
179
                return "$prompt_string \[$pwd\]"
180
            }
181
        }
182
183
        proc ls {args} {
184
            if {[exec uname -s] == "Linux"} {
185
                eval exec ls --color -FC [::tclreadline::Glob $args]
186
            } else {
187
                eval exec ls -FC [::tclreadline::Glob $args]
188
            }
189
        }
190
191
        if {[info procs cd] == ""} {
192
            catch {rename ::tclreadline::Cd ""}
193
            rename cd ::tclreadline::Cd
194
            proc cd {args} {
195
                if {[catch {eval ::tclreadline::Cd $args} message]} {
196
                    puts stderr "$message"
197
                }
198
                ls
199
            }
200
        }
201
202
        if {[info procs exit] == ""} {
203
204
            catch {rename ::tclreadline::Exit ""}
205
            rename exit ::tclreadline::Exit
206
207
            proc exit {args} {
208
209
                catch {
210
                    ::tclreadline::readline write \
211
                    [::tclreadline::HistoryFileGet]
212
                }
213
214
                if [catch "eval ::tclreadline::Exit $args" message] {
215
                    puts stderr "error:"
216
                    puts stderr "$message"
217
                }
218
                # NOTREACHED
219
            }
220
        }
221
222
    }
223
224
225
226
    global pi
227
    set pi 3.1415926535897931
228
    set tcl_precision 17
229
230
231
232
    global env
233
    variable historyfile
234
235
236
    if [info exists env(HOME)] {
237
        set historyfile  $env(HOME)/.tclsh-history
238
    } else {
239
        set historyfile  .tclsh-history
240
    }
241
    set msg [::tclreadline::readline initialize $historyfile]
242
    if {$msg != ""} {
243
        puts stderr "$msg"
244
    }
245
246
    ::tclreadline::InitCmds
247
248
    rename ::tclreadline::Setup ""
249
}
250
251
proc ::tclreadline::HistoryFileGet {} {
252
    variable historyfile
253
    return $historyfile
254
}
255
256
proc ::tclreadline::Glob {string} {
257
258
    set commandstring ""
259
    foreach name $string {
260
        set replace [glob -nocomplain -- $name]
261
        if {$replace == ""} {
262
            lappend commandstring $name
263
        } else {
264
            lappend commandstring $replace
265
        }
266
    }
267
    return $commandstring
268
}
269
270
271
272
proc ::tclreadline::Loop {} {
273
274
    ::tclreadline::Setup
275
276
    uplevel #0 {
277
278
        while {1} {
279
280
            if [info exists tcl_prompt2] {
281
                set ::tclreadline::prompt2 $tcl_prompt2
282
            } else {
283
                set ::tclreadline::prompt2 ">"
284
            }
285
286
            if {[namespace eval ::tclreadline {[info procs prompt1]}] != ""} {
287
                set ::tclreadline::LINE [::tclreadline::readline read \
288
                    [::tclreadline::prompt1]]
289
            } else {
290
                set ::tclreadline::LINE [::tclreadline::readline read %]
291
            }
292
293
            while {![::tclreadline::readline complete $::tclreadline::LINE]} {
294
                append ::tclreadline::LINE ";"
295
                append ::tclreadline::LINE [::tclreadline::readline read \
296
                    ${::tclreadline::prompt2}]
297
            }
298
299
300
            if [catch {
301
                set result [eval $::tclreadline::LINE]
302
                if {$result != "" && [::tclreadline::Print]} {
303
                    puts $result
304
                }
305
                set result ""
306
            } msg] {
307
                puts stderr $msg
308
            }
309
310
        }
311
    }
312
}
313
314
proc ::tclreadline::Print {args} {
315
    variable PRINT
316
    if ![info exists PRINT] {
317
        set ::tclreadline::PRINT yes
318
    }
319
    if [regexp -nocase \(true\|yes\|1\) $args] {
320
        set ::tclreadline::PRINT yes
321
    } elseif [regexp -nocase \(false\|no\|0\) $args] {
322
        set ::tclreadline::PRINT no
323
    }
324
    return $PRINT
325
}
326
327
proc ::tclreadline::InitCmds {} {
328
    global tcl_version tk_version
329
    if {[info exists tcl_version]} {
330
        ::tclreadline::InitTclCmds
331
    }
332
    if {[info exists tk_version]} {
333
        ::tclreadline::InitTkCmds
334
    }
335
    rename tclreadline::InitCmds ""
336
}
337
338
proc ::tclreadline::InitTclCmds {} {
339
::tclreadline::readline add "after option ?arg arg ...?"
340
::tclreadline::readline add "append varName ?value value ...?"
341
::tclreadline::readline add "array option arrayName ?arg ...?"
342
::tclreadline::readline add "binary option ?arg arg ...?"
343
::tclreadline::readline add "catch command ?varName?"
344
::tclreadline::readline add "clock option ?arg ...?"
345
::tclreadline::readline add "close channelId"
346
::tclreadline::readline add "eof channelId"
347
::tclreadline::readline add "error message ?errorInfo? ?errorCode?"
348
::tclreadline::readline add "eval arg ?arg ...?"
349
::tclreadline::readline add "exec ?switches? arg ?arg ...?"
350
::tclreadline::readline add "expr arg ?arg ...?"
351
::tclreadline::readline add "fblocked channelId"
352
::tclreadline::readline add "fconfigure channelId ?optionName? ?value? ?optionName value?..."
353
::tclreadline::readline add "fcopy input output ?-size size? ?-command callback?"
354
::tclreadline::readline add "file option ?arg ...?"
355
::tclreadline::readline add "fileevent channelId event ?script?"
356
::tclreadline::readline add "flush channelId"
357
::tclreadline::readline add "for start test next command"
358
::tclreadline::readline add "foreach varList list ?varList list ...? command"
359
::tclreadline::readline add "format formatString ?arg arg ...?"
360
::tclreadline::readline add "gets channelId ?varName?"
361
::tclreadline::readline add "glob ?switches? name ?name ...?"
362
::tclreadline::readline add "global varName ?varName ...?"
363
::tclreadline::readline add "incr varName ?increment?"
364
::tclreadline::readline add "info option ?arg arg ...?"
365
::tclreadline::readline add "interp cmd ?arg ...?"
366
::tclreadline::readline add "join list ?joinString?"
367
::tclreadline::readline add "lappend varName ?value value ...?"
368
::tclreadline::readline add "lindex list index"
369
::tclreadline::readline add "linsert list index element ?element ...?"
370
::tclreadline::readline add "llength list"
371
::tclreadline::readline add "load fileName ?packageName? ?interp?"
372
::tclreadline::readline add "lrange list first last"
373
::tclreadline::readline add "lreplace list first last ?element element ...?"
374
::tclreadline::readline add "lsearch ?mode? list pattern"
375
::tclreadline::readline add "lsort ?options? list"
376
::tclreadline::readline add "namespace subcommand ?arg ...?"
377
::tclreadline::readline add "open fileName ?access? ?permissions?"
378
::tclreadline::readline add "package option ?arg arg ...?"
379
::tclreadline::readline add "proc name args body"
380
::tclreadline::readline add "puts ?-nonewline? ?channelId? string"
381
::tclreadline::readline add "read ?-nonewline? channelId"
382
::tclreadline::readline add "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"
383
::tclreadline::readline add "regsub ?switches? exp string subSpec varName"
384
::tclreadline::readline add "rename oldName newName"
385
::tclreadline::readline add "scan string format ?varName varName ...?"
386
::tclreadline::readline add "seek channelId offset ?origin?"
387
::tclreadline::readline add "set varName ?newValue?"
388
::tclreadline::readline add "socket ?-myaddr addr? ?-myport myport? ?-async? host port"
389
::tclreadline::readline add "socket -server command ?-myaddr addr? port"
390
::tclreadline::readline add "source fileName"
391
::tclreadline::readline add "split string ?splitChars?"
392
::tclreadline::readline add "string option arg ?arg ...?"
393
::tclreadline::readline add "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"
394
::tclreadline::readline add "switch ?switches? string pattern body ... ?default body?"
395
::tclreadline::readline add "tell channelId"
396
::tclreadline::readline add "time command ?count?"
397
::tclreadline::readline add "trace option \[arg arg ...\]"
398
::tclreadline::readline add "unset varName ?varName ...?"
399
::tclreadline::readline add "uplevel ?level? command ?arg ...?"
400
::tclreadline::readline add "upvar ?level? otherVar localVar ?otherVar localVar ...?"
401
::tclreadline::readline add "vwait name"
402
::tclreadline::readline add "while test command"
403
rename tclreadline::InitTclCmds ""
404
405
}
406
407
proc ::tclreadline::InitTkCmds {} {
408
::tclreadline::readline add "bind window ?pattern? ?command?"
409
::tclreadline::readline add "bindtags window ?tags?"
410
::tclreadline::readline add "button pathName ?options?"
411
::tclreadline::readline add "canvas pathName ?options?"
412
::tclreadline::readline add "checkbutton pathName ?options?"
413
::tclreadline::readline add "clipboard option ?arg arg ...?"
414
::tclreadline::readline add "entry pathName ?options?"
415
::tclreadline::readline add "event option ?arg1?"
416
::tclreadline::readline add "font option ?arg?"
417
::tclreadline::readline add "frame pathName ?options?"
418
::tclreadline::readline add "grab option ?arg arg ...?"
419
::tclreadline::readline add "grid option arg ?arg ...?"
420
::tclreadline::readline add "image option ?args?"
421
::tclreadline::readline add "label pathName ?options?"
422
::tclreadline::readline add "listbox pathName ?options?"
423
::tclreadline::readline add "lower window ?belowThis?"
424
::tclreadline::readline add "menu pathName ?options?"
425
::tclreadline::readline add "menubutton pathName ?options?"
426
::tclreadline::readline add "message pathName ?options?"
427
::tclreadline::readline add "option cmd arg ?arg ...?"
428
::tclreadline::readline add "pack option arg ?arg ...?"
429
::tclreadline::readline add "radiobutton pathName ?options?"
430
::tclreadline::readline add "raise window ?aboveThis?"
431
::tclreadline::readline add "scale pathName ?options?"
432
::tclreadline::readline add "scrollbar pathName ?options?"
433
::tclreadline::readline add "selection option ?arg arg ...?"
434
::tclreadline::readline add "send ?options? interpName arg ?arg ...?"
435
::tclreadline::readline add "text pathName ?options?"
436
::tclreadline::readline add "tk option ?arg?"
437
::tclreadline::readline add "tkwait variable|visibility|window name"
438
::tclreadline::readline add "toplevel pathName ?options?"
439
::tclreadline::readline add "winfo option ?arg?"
440
::tclreadline::readline add "wm option window ?arg ...?"
441
rename tclreadline::InitTkCmds ""
442
}
443

Get latest updates about Open Source Projects, Conferences and News.

Sign up for the SourceForge newsletter:

JavaScript is required for this form.





No, thanks