ed find key */ #define KEY_SHELP 0606 /* shifted help key */ #define KEY_SHOME 0607 /* shifted home key */ #define KEY_SIC 0610 /* shifted insert-character key */ #define KEY_SLEFT 0611 /* shifted left-arrow key */ #define KEY_SMESSAGE 0612 /* shifted message key */ #define KEY_SMOVE 0613 /* shifted move key */ #define KEY_SNEXT 0614 /* shifted next key */ #define KEY_SOPTIONS 0615 /* shifted options key */ #define KEY_SPREVIOUS 0616 /* shifted previous key */ #define KEY_SPRINT 0617 /* shifted print key */ #define KEY_SREDO 0620 /* shifted redo key */ #define KEY_SREPLACE 0621 /* shifted replace key */ #define KEY_SRIGHT 0622 /* shifted right-arrow key */ #define KEY_SRSUME 0623 /* shifted resume key */ #define KEY_SSAVE 0624 /* shifted save key */ #define KEY_SSUSPEND 0625 /* shifted suspend key */ #define KEY_SUNDO 0626 /* shifted undo key */ #define KEY_SUSPEND 0627 /* suspend key */ #define KEY_UNDO 0630 /* undo key */ #define KEY_MOUSE 0631 /* Mouse event has occurred */ #define KEY_RESIZE 0632 /* Terminal resize event */ #define KEY_EVENT 0633 /* We were interrupted by an event */ #define KEY_MAX 0777 /* Maximum key value is 0633 */ /* * This file is part of ncurses, designed to be appended after curses.h.in * (see that file for the relevant copyright). */ /* $Id: curses.tail,v 1.14 2006/05/27 16:28:29 tom Exp $ */ /* mouse interface */ #if NCURSES_MOUSE_VERSION > 1 #define NCURSES_MOUSE_MASK(b,m) ((m) << (((b) - 1) * 5)) #else #define NCURSES_MOUSE_MASK(b,m) ((m) << (((b) - 1) * 6)) #endif #define NCURSES_BUTTON_RELEASED 001L #define NCURSES_BUTTON_PRESSED 002L #define NCURSES_BUTTON_CLICKED 004L #define NCURSES_DOUBLE_CLICKED 010L #define NCURSES_TRIPLE_CLICKED 020L #define NCURSES_RESERVED_EVENT 040L /* event masks */ #define BUTTON1_RELEASED NCURSES_MOUSE_MASK(1, NCURSES_BUTTON_RELEASED) #define BUTTON1_PRESSED NCURSES_MOUSE_MASK(1, NCURSES_BUTTON_PRESSED) #define BUTTON1_CLICKED NCURSES_MOUSE_MASK(1, NCURSES_BUTTON_CLICKED) #define BUTTON1_DOUBLE_CLICKED NCURSES_MOUSE_MASK(1, NCURSES_DOUBLE_CLICKED) #define BUTTON1_TRIPLE_CLICKED NCURSES_MOUSE_MASK(1, NCURSES_TRIPLE_CLICKED) #define BUTTON2_RELEASED NCURSES_MOUSE_MASK(2, NCURSES_BUTTON_RELEASED) #define BUTTON2_PRESSED NCURSES_MOUSE_MASK(2, NCURSES_BUTTON_PRESSED) #define BUTTON2_CLICKED NCURSES_MOUSE_MASK(2, NCURSES_BUTTON_CLICKED) #define BUTTON2_DOUBLE_CLICKED NCURSES_MOUSE_MASK(2, NCURSES_DOUBLE_CLICKED) #define BUTTON2_TRIPLE_CLICKED NCURSES_MOUSE_MASK(2, NCURSES_TRIPLE_CLICKED) #define BUTTON3_RELEASED NCURSES_MOUSE_MASK(3, NCURSES_BUTTON_RELEASED) #define BUTTON3_PRESSED NCURSES_MOUSE_MASK(3, NCURSES_BUTTON_PRESSED) #define BUTTON3_CLICKED NCURSES_MOUSE_MASK(3, NCURSES_BUTTON_CLICKED) #define BUTTON3_DOUBLE_CLICKED NCURSES_MOUSE_MASK(3, NCURSES_DOUBLE_CLICKED) #define BUTTON3_TRIPLE_CLICKED NCURSES_MOUSE_MASK(3, NCURSES_TRIPLE_CLICKED) #define BUTTON4_RELEASED NCURSES_MOUSE_MASK(4, NCURSES_BUTTON_RELEASED) #define BUTTON4_PRESSED NCURSES_MOUSE_MASK(4, NCURSES_BUTTON_PRESSED) #define BUTTON4_CLICKED NCURSES_MOUSE_MASK(4, NCURSES_BUTTON_CLICKED) #define BUTTON4_DOUBLE_CLICKED NCURSES_MOUSE_MASK(4, NCURSES_DOUBLE_CLICKED) #define BUTTON4_TRIPLE_CLICKED NCURSES_MOUSE_MASK(4, NCURSES_TRIPLE_CLICKED) /* * In 32 bits the version-1 scheme does not provide enough space for a 5th * button, unless we choose to change the ABI by omitting the reserved-events. */ #if NCURSES_MOUSE_VERSION > 1 #define BUTTON5_RELEASED NCURSES_MOUSE_MASK(5, NCURSES_BUTTON_RELEASED) #define BUTTON5_PRESSED NCURSES_MOUSE_MASK(5, NCURSES_BUTTON_PRESSED) #define BUTTON5_CLICKED NCURSES_MOUSE_MASK(5, NCURSES_BUTTON_CLICKED) #define BUTTON5_DOUBLE_CLICKED NCURSES_MOUSE_MASK(5, NCURSES_DOUBLE_CLICKED) #define BUTTON5_TRIPLE_CLICKED NCURSES_MOUSE_MASK(5, NCURSES_TRIPLE_CLICKED) #define BUTTON_CTRL NCURSES_MOUSE_MASK(6, 0001L) #define BUTTON_SHIFT NCURSES_MOUSE_MASK(6, 0002L) #define BUTTON_ALT NCURSES_MOUSE_MASK(6, 0004L) #define REPORT_MOUSE_POSITION NCURSES_MOUSE_MASK(6, 0010L) #else #define BUTTON1_RESERVED_EVENT NCURSES_MOUSE_MASK(1, NCURSES_RESERVED_EVENT) #define BUTTON2_RESERVED_EVENT NCURSES_MOUSE_MASK(2, NCURSES_RESERVED_EVENT) #define BUTTON3_RESERVED_EVENT NCURSES_MOUSE_MASK(3, NCURSES_RESERVED_EVENT) #define BUTTON4_RESERVED_EVENT NCURSES_MOUSE_MASK(4, NCURSES_RESERVED_EVENT) #define BUTTON_CTRL NCURSES_MOUSE_MASK(5, 0001L) #define BUTTON_SHIFT NCURSES_MOUSE_MASK(5, 0002L) #define BUTTON_ALT NCURSES_MOUSE_MASK(5, 0004L) #define REPORT_MOUSE_POSITION NCURSES_MOUSE_MASK(5, 0010L) #endif #define ALL_MOUSE_EVENTS (REPORT_MOUSE_POSITION - 1) /* macros to extract single event-bits from masks */ #define BUTTON_RELEASE(e, x) ((e) & (001 << (6 * ((x) - 1)))) #define BUTTON_PRESS(e, x) ((e) & (002 << (6 * ((x) - 1)))) #define BUTTON_CLICK(e, x) ((e) & (004 << (6 * ((x) - 1)))) #define BUTTON_DOUBLE_CLICK(e, x) ((e) & (010 << (6 * ((x) - 1)))) #define BUTTON_TRIPLE_CLICK(e, x) ((e) & (020 << (6 * ((x) - 1)))) #define BUTTON_RESERVED_EVENT(e, x) ((e) & (040 << (6 * ((x) - 1)))) typedef struct { short id; /* ID to distinguish multiple devices */ int x, y, z; /* event coordinates (character-cell) */ mmask_t bstate; /* button state bits */ } MEVENT; extern NCURSES_EXPORT(int) getmouse (MEVENT *); extern NCURSES_EXPORT(int) ungetmouse (MEVENT *); extern NCURSES_EXPORT(mmask_t) mousemask (mmask_t, mmask_t *); extern NCURSES_EXPORT(bool) wenclose (const WINDOW *, int, int); extern NCURSES_EXPORT(int) mouseinterval (int); extern NCURSES_EXPORT(bool) wmouse_trafo (const WINDOW*, int*, int*, bool); extern NCURSES_EXPORT(bool) mouse_trafo (int*, int*, bool); /* generated */ #define mouse_trafo(y,x,to_screen) wmouse_trafo(stdscr,y,x,to_screen) /* other non-XSI functions */ extern NCURSES_EXPORT(int) mcprint (char *, int); /* direct data to printer */ extern NCURSES_EXPORT(int) has_key (int); /* do we have given key? */ /* Debugging : use with libncurses_g.a */ extern NCURSES_EXPORT(void) _tracef (const char *, ...) GCC_PRINTFLIKE(1,2); extern NCURSES_EXPORT(void) _tracedump (const char *, WINDOW *); extern NCURSES_EXPORT(char *) _traceattr (attr_t); extern NCURSES_EXPORT(char *) _traceattr2 (int, chtype); extern NCURSES_EXPORT(char *) _nc_tracebits (void); extern NCURSES_EXPORT(char *) _tracechar (int); extern NCURSES_EXPORT(char *) _tracechtype (chtype); extern NCURSES_EXPORT(char *) _tracechtype2 (int, chtype); #ifdef _XOPEN_SOURCE_EXTENDED #define _tracech_t _tracecchar_t extern NCURSES_EXPORT(char *) _tracecchar_t (const cchar_t *); #define _tracech_t2 _tracecchar_t2 extern NCURSES_EXPORT(char *) _tracecchar_t2 (int, const cchar_t *); #else #define _tracech_t _tracechtype #define _tracech_t2 _tracechtype2 #endif extern NCURSES_EXPORT(char *) _tracemouse (const MEVENT *); extern NCURSES_EXPORT(void) trace (const unsigned int); /* trace masks */ #define TRACE_DISABLE 0x0000 /* turn off tracing */ #define TRACE_TIMES 0x0001 /* trace user and system times of updates */ #define TRACE_TPUTS 0x0002 /* trace tputs calls */ #define TRACE_UPDATE 0x0004 /* trace update actions, old & new screens */ #define TRACE_MOVE 0x0008 /* trace cursor moves and scrolls */ #define TRACE_CHARPUT 0x0010 /* trace all character outputs */ #define TRACE_ORDINARY 0x001F /* trace all update actions */ #define TRACE_CALLS 0x0020 /* trace all curses calls */ #define TRACE_VIRTPUT 0x0040 /* trace virtual character puts */ #define TRACE_IEVENT 0x0080 /* trace low-level input processing */ #define TRACE_BITS 0x0100 /* trace state of TTY control bits */ #define TRACE_ICALLS 0x0200 /* trace internal/nested calls */ #define TRACE_CCALLS 0x0400 /* trace per-character calls */ #define TRACE_DATABASE 0x0800 /* trace read/write of terminfo/termcap data */ #define TRACE_ATTRS 0x1000 /* trace attribute updates */ #define TRACE_SHIFT 13 /* number of bits in the trace masks */ #define TRACE_MAXIMUM ((1 << TRACE_SHIFT) - 1) /* maximum trace level */ #if defined(TRACE) || defined(NCURSES_TEST) extern NCURSES_EXPORT_VAR(int) _nc_optimize_enable; /* enable optimizations */ extern NCURSES_EXPORT(const char *) _nc_visbuf (const char *); #define OPTIMIZE_MVCUR 0x01 /* cursor movement optimization */ #define OPTIMIZE_HASHMAP 0x02 /* diff hashing to detect scrolls */ #define OPTIMIZE_SCROLL 0x04 /* scroll optimization */ #define OPTIMIZE_ALL 0xff /* enable all optimizations (dflt) */ #endif #ifdef __cplusplus #ifndef NCURSES_NOMACROS /* these names conflict with STL */ #undef box #undef clear #undef erase #undef move #undef refresh #endif /* NCURSES_NOMACROS */ } #endif #endif /* __NCURSES_H */ /* Copyright (C) 1991, 1996, 1997 Free Software Foundation, Inc. This file is part of the GNU C Library. The GNU C Library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with the GNU C Library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ /* * SVID */ #ifndef _MEMORY_H #define _MEMORY_H 1 #include #ifndef _STRING_H # include #endif /* string.h */ #endif /* memory.h */ ô$ semaphore.hõ$crypt.hö$Ü ncurses.h/* Linuxthreads - a simple clone()-based implementation of Posix */ /* threads for Linux. */ /* Copyright (C) 1996 Xavier Leroy (Xavier.Leroy@inria.fr) */ /* */ /* This program is free software; you can redistribute it and/or */ /* modify it under the terms of the GNU Library General Public License */ /* as published by the Free Software Foundation; either version 2 */ /* of the License, or (at your option) any later version. */ /* */ /* This program is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU Library General Public License for more details. */ #ifndef _SEMAPHORE_H #define _SEMAPHORE_H 1 #include #include #ifdef __USE_XOPEN2K # define __need_timespec # include #endif #ifndef _PTHREAD_DESCR_DEFINED /* Thread descriptors. Needed for `sem_t' definition. */ typedef struct _pthread_descr_struct *_pthread_descr; # define _PTHREAD_DESCR_DEFINED #endif /* System specific semaphore definition. */ typedef struct { struct _pthread_fastlock __sem_lock; int __sem_value; _pthread_descr __sem_waiting; } sem_t; /* Value returned if `sem_open' failed. */ #define SEM_FAILED ((sem_t *) 0) /* Maximum value the semaphore can have. */ #define SEM_VALUE_MAX ((int) ((~0u) >> 1)) __BEGIN_DECLS /* Initialize semaphore object SEM to VALUE. If PSHARED then share it with other processes. */ extern int sem_init (sem_t *__sem, int __pshared, unsigned int __value) __THROW; /* Free resources associated with semaphore object SEM. */ extern int sem_destroy (sem_t *__sem) __THROW; /* Open a named semaphore NAME with open flags OFLAG. */ extern sem_t *sem_open (__const char *__name, int __oflag, ...) __THROW; /* Close descriptor for named semaphore SEM. */ extern int sem_close (sem_t *__sem) __THROW; /* Remove named semaphore NAME. */ extern int sem_unlink (__const char *__name) __THROW; /* Wait for SEM being posted. This function is a cancellation point and therefore not marked with __THROW. */ extern int sem_wait (sem_t *__sem); #ifdef __USE_XOPEN2K /* Similar to `sem_wait' but wait only until ABSTIME. This function is a cancellation point and therefore not marked with __THROW. */ extern int sem_timedwait (sem_t *__restrict __sem, __const struct timespec *__restrict __abstime); #endif /* Test whether SEM is posted. */ extern int sem_trywait (sem_t *__sem) __THROW; /* Post SEM. */ extern int sem_post (sem_t *__sem) __THROW; /* Get current value of SEM and store it in *SVAL. */ extern int sem_getvalue (sem_t *__restrict __sem, int *__restrict __sval) __THROW; __END_DECLS #endif /* semaphore.h */ /* * crypt(3) implementation for uClibc * * The uClibc Library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version. * * The GNU C Library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with the GNU C Library; if not, write to the Free * Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA * 02111-1307 USA. * */ #ifndef _CRYPT_H #define _CRYPT_H 1 #include __BEGIN_DECLS /* Encrypt characters from KEY using salt to perturb the encryption method. * If salt begins with "$1$", MD5 hashing is used instead of DES. */ extern char *crypt (const char *__key, const char *__salt) __THROW __nonnull ((1, 2)); /* Setup DES tables according KEY. */ extern void setkey (const char *__key) __THROW __nonnull ((1)); /* Encrypt data in BLOCK in place if EDFLAG is zero; otherwise decrypt block in place. */ extern void encrypt (char *__block, int __edflag) __THROW __nonnull ((1)); __END_DECLS #endif /* crypt.h */ ÷$ .‚ ..›2 mannü2 man13 man3À-Äman7# auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # # RCS: @(#) $Id: auto.tcl,v 1.12.2.10 2005/07/23 03:31:41 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # auto_reset -- # # Destroy all cached information for auto-loading and auto-execution, # so that the information gets recomputed the next time it's needed. # Also delete any procedures that are listed in the auto-load index # except those defined in this file. # # Arguments: # None. proc auto_reset {} { global auto_execs auto_index auto_oldpath foreach p [info procs] { if {[info exists auto_index($p)] && ![string match auto_* $p] && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup tcl_findLibrary pkg_compareExtension tclPkgUnknown tcl::MacOSXPkgUnknown tcl::MacPkgUnknown} $p] < 0)} { rename $p {} } } unset -nocomplain auto_execs auto_index auto_oldpath } # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory # using a canonical searching algorithm. A side effect is to source # the initialization script and set a global library variable. # # Arguments: # basename Prefix of the directory name, (e.g., "tk") # version Version number of the package, (e.g., "8.0") # patch Patchlevel of the package, (e.g., "8.0.3") # initScript Initialization script to source (e.g., tk.tcl) # enVarName environment variable to honor (e.g., TK_LIBRARY) # varName Global variable to set when done (e.g., tk_library) proc tcl_findLibrary {basename version patch initScript enVarName varName} { upvar #0 $varName the_library global env errorInfo set dirs {} set errors {} # The C application may have hardwired a path, which we honor if {[info exists the_library] && $the_library ne ""} { lappend dirs $the_library } else { # Do the canonical search # 1. From an environment variable, if it exists. # Placing this first gives the end-user ultimate control # to work-around any bugs, or to customize. if {[info exists env($enVarName)]} { lappend dirs $env($enVarName) } # 2. In the package script directory registered within # the configuration of the package itself. # # Only do this for Tcl 8.5+, when Tcl_RegsiterConfig() is available. #if {[catch { # ::${basename}::pkgconfig get scriptdir,runtime #} value] == 0} { # lappend dirs $value #} # 3. Relative to auto_path directories. This checks relative to the # Tcl library as well as allowing loading of libraries added to the # auto_path that is not relative to the core library or binary paths. foreach d $::auto_path { lappend dirs [file join $d $basename$version] if {$::tcl_platform(platform) eq "unix" && $::tcl_platform(os) eq "Darwin"} { # 4. On MacOSX, check the Resources/Scripts subdir too lappend dirs [file join $d $basename$version Resources Scripts] } } # 3. Various locations relative to the executable # ../lib/foo1.0 (From bin directory in install hierarchy) # ../../lib/foo1.0 (From bin/arch directory in install hierarchy) # ../library (From unix directory in build hierarchy) set parentDir [file dirname [file dirname [info nameofexecutable]]] set grandParentDir [file dirname $parentDir] lappend dirs [file join $parentDir lib $basename$version] lappend dirs [file join $grandParentDir lib $basename$version] lappend dirs [file join $parentDir library] # Remaining locations are out of date (when relevant, they ought # to be covered by the $::auto_path seach above). # # ../../library (From unix/arch directory in build hierarchy) # ../../foo1.0.1/library # (From unix directory in parallel build hierarchy) # ../../../foo1.0.1/library # (From unix/arch directory in parallel build hierarchy) # # For the sake of extra compatibility safety, we keep adding these # paths during the 8.4.* release series. if {1} { lappend dirs [file join $grandParentDir library] lappend dirs [file join $grandParentDir $basename$patch library] lappend dirs [file join [file dirname $grandParentDir] \ $basename$patch library] } } # uniquify $dirs in order array set seen {} foreach i $dirs { # For Tcl 8.4.9, we've disabled the use of [file normalize] here. # This means that two different path names that are the same path # in normalized form, will both remain on the search path. There # should be no harm in that, just a bit more file system access # than is strictly necessary. # # [file normalize] has been disabled because of reports it has # caused difficulties with the freewrap utility. To keep # compatibility with freewrap's needs, we'll keep this disabled # throughout the 8.4.x (x >= 9) releases. See Bug 1072136. if {1 || [interp issafe]} { set norm $i } else { set norm [file normalize $i] } if {[info exists seen($norm)]} { continue } set seen($norm) "" lappend uniqdirs $i } set dirs $uniqdirs foreach i $dirs { set the_library $i set file [file join $i $initScript] # source everything when in a safe interpreter because # we have a source command, but no file exists command if {[interp issafe] || [file exists $file]} { if {![catch {uplevel #0 [list source $file]} msg]} { return } else { append errors "$file: $msg\n$errorInfo\n" } } } unset -nocomplain the_library set msg "Can't find a usable $initScript in the following directories: \n" append msg " $dirs\n\n" append msg "$errors\n\n" append msg "This probably means that $basename wasn't installed properly.\n" error $msg } # ---------------------------------------------------------------------- # auto_mkindex # ---------------------------------------------------------------------- # The following procedures are used to generate the tclIndex file # from Tcl source files. They use a special safe interpreter to # parse Tcl source files, writing out index entries as "proc" # commands are encountered. This implementation won't work in a # safe interpreter, since a safe interpreter can't create the # special parser and mess with its commands. if {[interp issafe]} { return ;# Stop sourcing the file here } # auto_mkindex -- # Regenerate a tclIndex file from Tcl source files. Takes as argument # the name of the directory in which the tclIndex file is to be placed, # followed by any number of glob patterns to use in that directory to # locate all of the relevant files. # # Arguments: # dir - Name of the directory in which to create an index. # args - Any number of additional arguments giving the # names of files within dir. If no additional # are given auto_mkindex will look for *.tcl. proc auto_mkindex {dir args} { global errorCode errorInfo if {[interp issafe]} { error "can't generate index within safe interpreter" } set oldDir [pwd] cd $dir set dir [pwd] append index "# Tcl autoload index file, version 2.0\n" append index "# This file is generated by the \"auto_mkindex\" command\n" append index "# and sourced to set up indexing information for one or\n" append index "# more commands. Typically each line is a command that\n" append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init foreach file [eval [linsert $args 0 glob --]] { if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { append index $msg } else { set code $errorCode set info $errorInfo cd $oldDir error $msg $info $code } } auto_mkindex_parser::cleanup set fid [open "tclIndex" w] puts -nonewline $fid $index close $fid cd $oldDir } # Original version of auto_mkindex that just searches the source # code for "proc" at the beginning of the line. proc auto_mkindex_old {dir args} { global errorCode errorInfo set oldDir [pwd] cd $dir set dir [pwd] append index "# Tcl autoload index file, version 2.0\n" append index "# This file is generated by the \"auto_mkindex\" command\n" append index "# and sourced to set up indexing information for one or\n" append index "# more commands. Typically each line is a command that\n" append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" if {[llength $args] == 0} { set args *.tcl } foreach file [eval [linsert $args 0 glob --]] { set f "" set error [catch { set f [open $file] while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] append index "set [list auto_index($procName)]" append index " \[list source \[file join \$dir [list $file]\]\]\n" } } close $f } msg] if {$error} { set code $errorCode set info $errorInfo catch {close $f} cd $oldDir error $msg $info $code } } set f "" set error [catch { set f [open tclIndex w] puts -nonewline $f $index close $f cd $oldDir } msg] if {$error} { set code $errorCode set info $errorInfo catch {close $f} cd $oldDir error $msg $info $code } } # Create a safe interpreter that can be used to parse Tcl source files # generate a tclIndex file for autoloading. This interp contains # commands for things that need index entries. Each time a command # is executed, it writes an entry out to the index file. namespace eval auto_mkindex_parser { variable parser "" ;# parser used to build index variable index "" ;# maintains index as it is built variable scriptFile "" ;# name of file being processed variable contextStack "" ;# stack of namespace scopes variable imports "" ;# keeps track of all imported cmds variable initCommands "" ;# list of commands that create aliases proc init {} { variable parser variable initCommands if {![interp issafe]} { set parser [interp create -safe] $parser hide info $parser hide rename $parser hide proc $parser hide namespace $parser hide eval $parser hide puts $parser invokehidden namespace delete :: $parser invokehidden proc unknown {args} {} # We'll need access to the "namespace" command within the # interp. Put it back, but move it out of the way. $parser expose namespace $parser invokehidden rename namespace _%@namespace $parser expose eval $parser invokehidden rename eval _%@eval # Install all the registered psuedo-command implementations foreach cmd $initCommands { eval $cmd } } } proc cleanup {} { variable parser interp delete $parser unset parser } } # auto_mkindex_parser::mkindex -- # # Used by the "auto_mkindex" command to create a "tclIndex" file for # the given Tcl source file. Executes the commands in the file, and # handles things like the "proc" command by adding an entry for the # index file. Returns a string that represents the index file. # # Arguments: # file Name of Tcl source file to be indexed. proc auto_mkindex_parser::mkindex {file} { variable parser variable index variable scriptFile variable contextStack variable imports set scriptFile $file set fid [open $file] set contents [read $fid] close $fid # There is one problem with sourcing files into the safe # interpreter: references like "$x" will fail since code is not # really being executed and variables do not really exist. # To avoid tŸ» »¡»¢»£»¤»¥»¦»§»his, we replace all $ with \0 (literally, the null char) # later, when getting proc names we will have to reverse this replacement, # in case there were any $ in the proc name. This will cause a problem # if somebody actually tries to have a \0 in their proc name. Too bad # for them. set contents [string map "$ \u0000" $contents] set index "" set contextStack "" set imports "" $parser eval $contents foreach name $imports { catch {$parser eval [list _%@namespace forget $name]} } return $index } # auto_mkindex_parser::hook command # # Registers a Tcl command to evaluate when initializing the # slave interpreter used by the mkindex parser. # The command is evaluated in the master interpreter, and can # use the variable auto_mkindex_parser::parser to get to the slave proc auto_mkindex_parser::hook {cmd} { variable initCommands lappend initCommands $cmd } # auto_mkindex_parser::slavehook command # # Registers a Tcl command to evaluate when initializing the # slave interpreter used by the mkindex parser. # The command is evaluated in the slave interpreter. proc auto_mkindex_parser::slavehook {cmd} { variable initCommands # The $parser variable is defined to be the name of the # slave interpreter when this command is used later. lappend initCommands "\$parser eval [list $cmd]" } # auto_mkindex_parser::command -- # # Registers a new command with the "auto_mkindex_parser" interpreter # that parses Tcl files. These commands are fake versions of things # like the "proc" command. When you execute them, they simply write # out an entry to a "tclIndex" file for auto-loading. # # This procedure allows extensions to register their own commands # with the auto_mkindex facility. For example, a package like # [incr Tcl] might register a "class" command so that class definitions # could be added to a "tclIndex" file for auto-loading. # # Arguments: # name Name of command recognized in Tcl files. # arglist Argument list for command. # body Implementation of command to handle indexing. proc auto_mkindex_parser::command {name arglist body} { hook [list auto_mkindex_parser::commandInit $name $arglist $body] } # auto_mkindex_parser::commandInit -- # # This does the actual work set up by auto_mkindex_parser::command # This is called when the interpreter used by the parser is created. # # Arguments: # name Name of command recognized in Tcl files. # arglist Argument list for command. # body Implementation of command to handle indexing. proc auto_mkindex_parser::commandInit {name arglist body} { variable parser set ns [namespace qualifiers $name] set tail [namespace tail $name] if {$ns eq ""} { set fakeName [namespace current]::_%@fake_$tail } else { set fakeName [namespace current]::[string map {:: _} _%@fake_$name] } proc $fakeName $arglist $body # YUK! Tcl won't let us alias fully qualified command names, # so we can't handle names like "::itcl::class". Instead, # we have to build procs with the fully qualified names, and # have the procs point to the aliases. if {[string match *::* $name]} { set exportCmd [list _%@namespace export [namespace tail $name]] $parser eval [list _%@namespace eval $ns $exportCmd] # The following proc definition does not work if you # want to tolerate space or something else diabolical # in the procedure name, (i.e., space in $alias) # The following does not work: # "_%@eval {$alias} \$args" # because $alias gets concat'ed to $args. # The following does not work because $cmd is somehow undefined # "set cmd {$alias} \; _%@eval {\$cmd} \$args" # A gold star to someone that can make test # autoMkindex-3.3 work properly set alias [namespace tail $fakeName] $parser invokehidden proc $name {args} "_%@eval {$alias} \$args" $parser alias $alias $fakeName } else { $parser alias $name $fakeName } return } # auto_mkindex_parser::fullname -- # Used by commands like "proc" within the auto_mkindex parser. # Returns the qualified namespace name for the "name" argument. # If the "name" does not start with "::", elements are added from # the current namespace stack to produce a qualified name. Then, # the name is examined to see whether or not it should really be # qualified. If the name has more than the leading "::", it is # returned as a fully qualified name. Otherwise, it is returned # as a simple name. That way, the Tcl autoloader will recognize # it properly. # # Arguments: # name - Name that is being added to index. proc auto_mkindex_parser::fullname {name} { variable contextStack if {![string match ::* $name]} { foreach ns $contextStack { set name "${ns}::$name" if {[string match ::* $name]} { break } } } if {[namespace qualifiers $name] eq ""} { set name [namespace tail $name] } elseif {![string match ::* $name]} { set name "::$name" } # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse # that replacement. return [string map "\u0000 $" $name] } # Register all of the procedures for the auto_mkindex parser that # will build the "tclIndex" file. # AUTO MKINDEX: proc name arglist body # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { variable index variable scriptFile # Do some fancy reformatting on the "source" call to handle platform # differences with respect to pathnames. Use format just so that the # command is a little easier to read (otherwise it'd be full of # backslashed dollar signs, etc. append index [list set auto_index([fullname $name])] \ [format { [list source [file join $dir %s]]} \ [file split $scriptFile]] "\n" } # Conditionally add support for Tcl byte code files. There are some # tricky details here. First, we need to get the tbcload library # initialized in the current interpreter. We cannot load tbcload into the # slave until we have done so because it needs access to the tcl_patchLevel # variable. Second, because the package index file may defer loading the # library until we invoke a command, we need to explicitly invoke auto_load # to force it to be loaded. This should be a noop if the package has # already been loaded auto_mkindex_parser::hook { if {![catch {package require tbcload}]} { if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } load {} tbcload $auto_mkindex_parser::parser # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { variable index variable scriptFile # Do some nice reformatting of the "source" call, to get around # path differences on different platforms. We use the format # command just so that the code is a little easier to read. append index [list set auto_index([fullname $name])] \ [format { [list source [file join $dir %s]]} \ [file split $scriptFile]] "\n" } } } # AUTO MKINDEX: namespace eval name command ?arg arg...? # Adds the namespace name onto the context stack and evaluates the # associated body of commands. # # AUTO MKINDEX: namespace import ?-force? pattern ?pattern...? # Performs the "import" action in the parser interpreter. This is # important for any commands contained in a namespace that affect # the index. For example, a script may say "itcl::class ...", # or it may import "itcl::*" and then say "class ...". This # procedure does the import operation, but keeps track of imported # patterns so we can remove the imports later. auto_mkindex_parser::command namespace {op args} { switch -- $op { eval { variable parser variable contextStack set name [lindex $args 0] set args [lrange $args 1 end] set contextStack [linsert $contextStack 0 $name] $parser eval [list _%@namespace eval $name] $args set contextStack [lrange $contextStack 1 end] } import { variable parser variable imports foreach pattern $args { if {$pattern ne "-force"} { lappend imports $pattern } } catch {$parser eval "_%@namespace import $args"} } } } return ù$ .á ..ú$ optparse.tclû$Ô pkgIndex.tcl# optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. # # RCS: @(#) $Id: optparse.tcl,v 1.8.2.1 2003/09/10 20:29:59 dgp Exp $ package require Tcl 8.2 # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. package provide opt 0.4.4.1 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ OptProc OptProcArgGiven OptParse \ Lempty Lget \ Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ SetMax SetMin ################# Example of use / 'user documentation' ################### proc OptCreateTestProc {} { # Defines ::tcl::OptParseTest as a test proc with parsed arguments # (can't be defined before the code below is loaded (before "OptProc")) # Every OptProc give usage information on "procname -help". # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and # then other arguments. # # example of 'valid' call: # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ # -nostatics false ch1 OptProc OptParseTest { {subcommand -choice {save print} "sub command"} {arg1 3 "some number"} {-aflag} {-intflag 7} {-weirdflag "help string"} {-noStatics "Not ok to load static packages"} {-nestedloading1 true "OK to load into nested slaves"} {-nestedloading2 -boolean true "OK to load into nested slaves"} {-libsOK -choice {Tk SybTcl} "List of packages that can be loaded"} {-precision -int 12 "Number of digits of precision"} {-intval 7 "An integer"} {-scale -float 1.0 "Scale factor"} {-zoom 1.0 "Zoom factor"} {-arbitrary foobar "Arbitrary string"} {-random -string 12 "Random string"} {-listval -list {} "List value"} {-blahflag -blah abc "Funny type"} {arg2 -boolean "a boolean"} {arg3 -choice "ch1 ch2"} {?optarg? -list {} "optional argument"} } { foreach v [info locals] { puts stderr [format "%14s : %s" $v [set $v]] } } } ################### No User serviceable part below ! ############### # Array storing the parsed descriptions variable OptDesc; array set OptDesc {}; # Next potentially free key id (numeric) variable OptDescN 0; # Inside algorithm/mechanism description: # (not for the faint hearted ;-) # # The argument description is parsed into a "program tree" # It is called a "program" because it is the program used by # the state machine interpreter that use that program to # actually parse the arguments at run time. # # The general structure of a "program" is # notation (pseudo bnf like) # name :== definition defines "name" as being "definition" # { x y z } means list of x, y, and z # x* means x repeated 0 or more time # x+ means "x x*" # x? means optionally x # x | y means x or y # "cccc" means the literal string # # program :== { programCounter programStep* } # # programStep :== program | singleStep # # programCounter :== {"P" integer+ } # # singleStep :== { instruction parameters* } # # instruction :== single element list # # (the difference between singleStep and program is that \ # llength [lindex $program 0] >= 2 # while # llength [lindex $singleStep 0] == 1 # ) # # And for this application: # # singleStep :== { instruction varname {hasBeenSet currentValue} type # typeArgs help } # instruction :== "flags" | "value" # type :== knowType | anyword # knowType :== "string" | "int" | "boolean" | "boolflag" | "float" # | "choice" # # for type "choice" typeArgs is a list of possible choices, the first one # is the default value. for all other types the typeArgs is the default value # # a "boolflag" is the type for a flag whose presence or absence, without # additional arguments means respectively true or false (default flag type). # # programCounter is the index in the list of the currently processed # programStep (thus starting at 1 (0 is {"P" prgCounterValue}). # If it is a list it points toward each currently selected programStep. # (like for "flags", as they are optional, form a set and programStep). # Performance/Implementation issues # --------------------------------- # We use tcl lists instead of arrays because with tcl8.0 # they should start to be much faster. # But this code use a lot of helper procs (like Lvarset) # which are quite slow and would be helpfully optimized # for instance by being written in C. Also our struture # is complex and there is maybe some places where the # string rep might be calculated at great exense. to be checked. # # Parse a given description and saves it here under the given key # generate a unused keyid if not given # proc ::tcl::OptKeyRegister {desc {key ""}} { variable OptDesc; variable OptDescN; if {[string equal $key ""]} { # in case a key given to us as a parameter was a number while {[info exists OptDesc($OptDescN)]} {incr OptDescN} set key $OptDescN; incr OptDescN; } # program counter set program [list [list "P" 1]]; # are we processing flags (which makes a single program step) set inflags 0; set state {}; # flag used to detect that we just have a single (flags set) subprogram. set empty 1; foreach item $desc { if {$state == "args"} { # more items after 'args'... return -code error "'args' special argument must be the last one"; } set res [OptNormalizeOne $item]; set state [lindex $res 0]; if {$inflags} { if {$state == "flags"} { # add to 'subprogram' lappend flagsprg $res; } else { # put in the flags # structure for flag programs items is a list of # {subprgcounter {prg flag 1} {prg flag 2} {...}} lappend program $flagsprg; # put the other regular stuff lappend program $res; set inflags 0; set empty 0; } } else { if {$state == "flags"} { set inflags 1; # sub program counter + first sub program set flagsprg [list [list "P" 1] $res]; } else { lappend program $res; set empty 0; } } } if {$inflags} { if {$empty} { # We just have the subprogram, optimize and remove # unneeded level: set program $flagsprg; } else { lappend program $flagsprg; } } set OptDesc($key) $program; return $key; } # # Free the storage for that given key # proc ::tcl::OptKeyDelete {key} { variable OptDesc; unset OptDesc($key); } # Get the parsed description stored under the given key. proc OptKeyGetDesc {descKey} { variable OptDesc; if {![info exists OptDesc($descKey)]} { return -code error "Unknown option description key \"$descKey\""; } set OptDesc($descKey); } # Parse entry point for ppl who don't want to register with a key, # for instance because the description changes dynamically. # (otherwise one should really use OptKeyRegister once + OptKeyParse # as it is way faster or simply OptProc which does it all) # Assign a temporary key, call OptKeyParse and then free the storage proc ::tcl::OptParse {desc arglist} { set tempkey [OptKeyRegister $desc]; set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res]; OptKeyDelete $tempkey; return -code $ret $res; } # Helper function, replacement for proc that both # register the description under a key which is the name of the proc # (and thus unique to that code) # and add a first line to the code to call the OptKeyParse proc # Stores the list of variables that have been actually given by the user # (the other will be sets to their default value) # into local variable named "Args". proc ::tcl::OptProc {name desc body} { set namespace [uplevel 1 [list ::namespace current]]; if {[string match "::*" $name] || [string equal $namespace "::"]} { # absolute name or global namespace, name is the key set key $name; } else { # we are relative to some non top level namespace: set key "${namespace}::${name}"; } OptKeyRegister $desc $key; uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]; return $key; } # Check that a argument has been given # assumes that "OptProc" has been used as it will check in "Args" list proc ::tcl::OptProcArgGiven {argname} { upvar Args alist; expr {[lsearch $alist $argname] >=0} } ####### # Programs/Descriptions manipulation # Return the instruction word/list of a given step/(sub)program proc OptInstr {lst} { lindex $lst 0; } # Is a (sub) program or a plain instruction ? proc OptIsPrg {lst} { expr {[llength [OptInstr $lst]]>=2} } # Is this instruction a program counter or a real instr proc OptIsCounter {item} { expr {[lindex $item 0]=="P"} } # Current program counter (2nd word of first word) proc OptGetPrgCounter {lst} { Lget $lst {0 1} } # Current program counter (2nd word of first word) proc OptSetPrgCounter {lstName newValue} { upvar $lstName lst; set lst [lreplace $lst 0 0 [concat "P" $newValue]]; } # returns a list of currently selected items. proc OptSelection {lst} { set res {}; foreach idx [lrange [lindex $lst 0] 1 end] { lappend res [Lget $lst $idx]; } return $res; } # Advance to next description proc OptNextDesc {descName} { uplevel 1 [list Lvarincr $descName {0 1}]; } # Get the current description, eventually descend proc OptCurDesc {descriptions} { lindex $descriptions [OptGetPrgCounter $descriptions]; } # get the current description, eventually descend # through sub programs as needed. proc OptCurDescFinal {descriptions} { set item [OptCurDesc $descriptions]; # Descend untill we get the actual item and not a sub program while {[OptIsPrg $item]} { set item [OptCurDesc $item]; } return $item; } # Current final instruction adress proc OptCurAddr {descriptions {start {}}} { set adress [OptGetPrgCounter $descriptions]; lappend start $adress; set item [lindex $descriptions $adress]; if {[OptIsPrg $item]} { return [OptCurAddr $item $start]; } else { return $start; } } # Set the value field of the current instruction proc OptCurSetValue {descriptionsName value} { upvar $descriptionsName descriptions # get the current item full adress set adress [OptCurAddr $descriptions]; # use the 3th field of the item (see OptValue / OptNewInst) lappend adress 2 Lvarset descriptions $adress [list 1 $value]; # ^hasBeenSet flag } # empty state means done/paste the end of the program proc OptState {item} { lindex $item 0 } # current state proc OptCurState {descriptions} { OptState [OptCurDesc $descriptions]; } ####### # Arguments manipulation # Returns the argument that has to be processed now proc OptCurrentArg {lst} { lindex $lst 0; } # Advance to next argument proc OptNextArg {argsName} { uplevel 1 [list Lvarpop1 $argsName]; } ####### # Loop over all descriptions, calling OptDoOne which w¶»·»¸»¹»º»»»¼»½»¾»¿»À»Á»Â»Ã»Ä»Å»Æ»Ç»È»É»Ê»ill # eventually eat all the arguments. proc OptDoAll {descriptionsName argumentsName} { upvar $descriptionsName descriptions upvar $argumentsName arguments; # puts "entered DoAll"; # Nb: the places where "state" can be set are tricky to figure # because DoOne sets the state to flagsValue and return -continue # when needed... set state [OptCurState $descriptions]; # We'll exit the loop in "OptDoOne" or when state is empty. while 1 { set curitem [OptCurDesc $descriptions]; # Do subprograms if needed, call ourselves on the sub branch while {[OptIsPrg $curitem]} { OptDoAll curitem arguments # puts "done DoAll sub"; # Insert back the results in current tree; Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ $curitem; OptNextDesc descriptions; set curitem [OptCurDesc $descriptions]; set state [OptCurState $descriptions]; } # puts "state = \"$state\" - arguments=($arguments)"; if {[Lempty $state]} { # Nothing left to do, we are done in this branch: break; } # The following statement can make us terminate/continue # as it use return -code {break, continue, return and error} # codes OptDoOne descriptions state arguments; # If we are here, no special return code where issued, # we'll step to next instruction : # puts "new state = \"$state\""; OptNextDesc descriptions; set state [OptCurState $descriptions]; } } # Process one step for the state machine, # eventually consuming the current argument. proc OptDoOne {descriptionsName stateName argumentsName} { upvar $argumentsName arguments; upvar $descriptionsName descriptions; upvar $stateName state; # the special state/instruction "args" eats all # the remaining args (if any) if {($state == "args")} { if {![Lempty $arguments]} { # If there is no additional arguments, leave the default value # in. OptCurSetValue descriptions $arguments; set arguments {}; } # puts "breaking out ('args' state: consuming every reminding args)" return -code break; } if {[Lempty $arguments]} { if {$state == "flags"} { # no argument and no flags : we're done # puts "returning to previous (sub)prg (no more args)"; return -code return; } elseif {$state == "optValue"} { set state next; # not used, for debug only # go to next state return ; } else { return -code error [OptMissingValue $descriptions]; } } else { set arg [OptCurrentArg $arguments]; } switch $state { flags { # A non-dash argument terminates the options, as does -- # Still a flag ? if {![OptIsFlag $arg]} { # don't consume the argument, return to previous prg return -code return; } # consume the flag OptNextArg arguments; if {[string equal "--" $arg]} { # return from 'flags' state return -code return; } set hits [OptHits descriptions $arg]; if {$hits > 1} { return -code error [OptAmbigous $descriptions $arg] } elseif {$hits == 0} { return -code error [OptFlagUsage $descriptions $arg] } set item [OptCurDesc $descriptions]; if {[OptNeedValue $item]} { # we need a value, next state is set state flagValue; } else { OptCurSetValue descriptions 1; } # continue return -code continue; } flagValue - value { set item [OptCurDesc $descriptions]; # Test the values against their required type if {[catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { return -code error [OptBadValue $item $arg $val] } # consume the value OptNextArg arguments; # set the value OptCurSetValue descriptions $val; # go to next state if {$state == "flagValue"} { set state flags return -code continue; } else { set state next; # not used, for debug only return ; # will go on next step } } optValue { set item [OptCurDesc $descriptions]; # Test the values against their required type if {![catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { # right type, so : # consume the value OptNextArg arguments; # set the value OptCurSetValue descriptions $val; } # go to next state set state next; # not used, for debug only return ; # will go on next step } } # If we reach this point: an unknown # state as been entered ! return -code error "Bug! unknown state in DoOne \"$state\"\ (prg counter [OptGetPrgCounter $descriptions]:\ [OptCurDesc $descriptions])"; } # Parse the options given the key to previously registered description # and arguments list proc ::tcl::OptKeyParse {descKey arglist} { set desc [OptKeyGetDesc $descKey]; # make sure -help always give usage if {[string equal -nocase "-help" $arglist]} { return -code error [OptError "Usage information:" $desc 1]; } OptDoAll desc arglist; if {![Lempty $arglist]} { return -code error [OptTooManyArgs $desc $arglist]; } # Analyse the result # Walk through the tree: OptTreeVars $desc "#[expr {[info level]-1}]" ; } # determine string length for nice tabulated output proc OptTreeVars {desc level {vnamesLst {}}} { foreach item $desc { if {[OptIsCounter $item]} continue; if {[OptIsPrg $item]} { set vnamesLst [OptTreeVars $item $level $vnamesLst]; } else { set vname [OptVarName $item]; upvar $level $vname var if {[OptHasBeenSet $item]} { # puts "adding $vname" # lets use the input name for the returned list # it is more usefull, for instance you can check that # no flags at all was given with expr # {![string match "*-*" $Args]} lappend vnamesLst [OptName $item]; set var [OptValue $item]; } else { set var [OptDefaultValue $item]; } } } return $vnamesLst } # Check the type of a value # and emit an error if arg is not of the correct type # otherwise returns the canonical value of that arg (ie 0/1 for booleans) proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # puts "checking '$arg' against '$type' ($typeArgs)"; # only types "any", "choice", and numbers can have leading "-" switch -exact -- $type { int { if {![string is integer -strict $arg]} { error "not an integer" } return $arg; } float { return [expr {double($arg)}] } script - list { # if llength fail : malformed list if {[llength $arg]==0 && [OptIsFlag $arg]} { error "no values with leading -" } return $arg; } boolean { if {![string is boolean -strict $arg]} { error "non canonic boolean" } # convert true/false because expr/if is broken with "!,... return [expr {$arg ? 1 : 0}] } choice { if {[lsearch -exact $typeArgs $arg] < 0} { error "invalid choice" } return $arg; } any { return $arg; } string - default { if {[OptIsFlag $arg]} { error "no values with leading -" } return $arg } } return neverReached; } # internal utilities # returns the number of flags matching the given arg # sets the (local) prg counter to the list of matches proc OptHits {descName arg} { upvar $descName desc; set hits 0 set hitems {} set i 1; set larg [string tolower $arg]; set len [string length $larg]; set last [expr {$len-1}]; foreach item [lrange $desc 1 end] { set flag [OptName $item] # lets try to match case insensitively # (string length ought to be cheap) set lflag [string tolower $flag]; if {$len == [string length $lflag]} { if {[string equal $larg $lflag]} { # Exact match case OptSetPrgCounter desc $i; return 1; } } elseif {[string equal $larg [string range $lflag 0 $last]]} { lappend hitems $i; incr hits; } incr i; } if {$hits} { OptSetPrgCounter desc $hitems; } return $hits } # Extract fields from the list structure: proc OptName {item} { lindex $item 1; } proc OptHasBeenSet {item} { Lget $item {2 0}; } proc OptValue {item} { Lget $item {2 1}; } proc OptIsFlag {name} { string match "-*" $name; } proc OptIsOpt {name} { string match {\?*} $name; } proc OptVarName {item} { set name [OptName $item]; if {[OptIsFlag $name]} { return [string range $name 1 end]; } elseif {[OptIsOpt $name]} { return [string trim $name "?"]; } else { return $name; } } proc OptType {item} { lindex $item 3 } proc OptTypeArgs {item} { lindex $item 4 } proc OptHelp {item} { lindex $item 5 } proc OptNeedValue {item} { expr {![string equal [OptType $item] boolflag]} } proc OptDefaultValue {item} { set val [OptTypeArgs $item] switch -exact -- [OptType $item] { choice {return [lindex $val 0]} boolean - boolflag { # convert back false/true to 0/1 because expr !$bool # is broken.. if {$val} { return 1 } else { return 0 } } } return $val } # Description format error helper proc OptOptUsage {item {what ""}} { return -code error "invalid description format$what: $item\n\ should be a list of {varname|-flagname ?-type? ?defaultvalue?\ ?helpstring?}"; } # Generate a canonical form single instruction proc OptNewInst {state varname type typeArgs help}