/* This code is automatically generated by "mktclapp" version 3.9 */ /* DO NOT EDIT */ #include #define INTERFACE 1 #if INTERFACE #define ET_TCLARGS ClientData clientData, Tcl_Interp *interp, int argc, char **argv #define ET_OBJARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[] #endif #define ET_ENABLE_OBJ 0 #define ET_ENABLE_TK 1 #define ET_AUTO_FORK 0 #define ET_STANDALONE 0 #define ET_N_BUILTIN_SCRIPT 2 #define ET_VERSION "3.9" #define ET_HAVE_APPINIT 0 #define ET_HAVE_PREINIT 0 #define ET_HAVE_MAIN 1 #define ET_HAVE_CUSTOM_MAINLOOP 0 #define ET_TCL_LIBRARY "C:/cygwin/usr/share/tcl8.0" #define ET_TK_LIBRARY "C:/cygwin/usr/share/tk8.0" #define ET_MAIN_SCRIPT "C:/cygwin/home/vertical/scripts/trial.tcl" #define ET_EXTENSION 0 #define ET_SHROUD_KEY 0 #define ET_READ_STDIN 1 #define ET_CONSOLE 0 extern int ET_COMMAND_vertical (ET_TCLARGS); extern int ET_COMMAND_wossat (ET_TCLARGS); static struct { char *zName; int (*xProc) (ET_TCLARGS); } Et_CmdSet[] = {{"vertical", ET_COMMAND_vertical}, {"wossat", ET_COMMAND_wossat}, {0, 0}}; static char Et_zFile0[] = "# Tcl autoload index file, version 2.0\n" "# This file is generated by the \"auto_mkindex\" command\n" "# and sourced to set up indexing information for one or\n" "# more commands. Typically each line is a command that\n" "# sets an element in the auto_index array, where the\n" "# element name is the name of a command and the value is\n" "# a script that loads the command.\n" "\n" "set auto_index(history) [list source [file join $dir history.tcl]]\n" "set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]\n" "set auto_index(parray) [list source [file join $dir parray.tcl]]\n" "set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]\n" "set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]\n" "set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]\n" "set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]\n" "set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]\n" "set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]\n" "set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]\n" "set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]\n" "set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]\n" "set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]\n" "set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]\n" "set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]\n"; static char Et_zFile1[] = "# Tcl autoload index file, version 2.0\n" "# This file is generated by the \"auto_mkindex\" command\n" "# and sourced to set up indexing information for one or\n" "# more commands. Typically each line is a command that\n" "# sets an element in the auto_index array, where the\n" "# element name is the name of a command and the value is\n" "# a script that loads the command.\n" "\n" "set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n" "set auto_index(tkCheckRadioEnter) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n" "set auto_index(tkCheckRadioDown) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonDown) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonUp) [list source [file join $dir button.tcl]]\n" "set auto_index(tkButtonInvoke) [list source [file join $dir button.tcl]]\n" "set auto_index(tkCheckRadioInvoke) [list source [file join $dir button.tcl]]\n" "set auto_index(tk_dialog) [list source [file join $dir dialog.tcl]]\n" "set auto_index(tkEntryClosestGap) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryButton1) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryMouseSelect) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryPaste) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryAutoScan) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryKeySelect) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryInsert) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryBackspace) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntrySeeInsert) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntrySetCursor) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryTranspose) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkEntryPreviousWord) [list source [file join $dir entry.tcl]]\n" "set auto_index(tkListboxBeginSelect) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxMotion) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxBeginExtend) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxBeginToggle) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxAutoScan) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxUpDown) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxExtendUpDown) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxDataExtend) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxCancel) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkListboxSelectAll) [list source [file join $dir listbox.tcl]]\n" "set auto_index(tkMbEnter) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMbLeave) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMbPost) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuUnpost) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMbMotion) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMbButtonUp) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuMotion) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuButtonDown) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuLeave) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuInvoke) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuEscape) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuUpArrow) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuDownArrow) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuLeftArrow) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuRightArrow) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuNextMenu) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuNextEntry) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuFind) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkTraverseToMenu) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkFirstMenu) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkTraverseWithinMenu) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuFirstEntry) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkMenuFindName) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkPostOverPoint) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkSaveGrabInfo) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkRestoreOldGrab) [list source [file join $dir menu.tcl]]\n" "set auto_index(tk_menuSetFocus) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkGenerateMenuSelect) [list source [file join $dir menu.tcl]]\n" "set auto_index(tk_popup) [list source [file join $dir menu.tcl]]\n" "set auto_index(tkScrollButtonDown) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollButtonUp) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollSelect) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollStartDrag) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollDrag) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollEndDrag) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollByUnits) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollByPages) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollToPos) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollTopBottom) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkScrollButton2Down) [list source [file join $dir scrlbar.tcl]]\n" "set auto_index(tkTextClosestGap) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextButton1) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextSelectTo) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextKeyExtend) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextPaste) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextAutoScan) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextSetCursor) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextKeySelect) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextResetAnchor) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextInsert) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextUpDownLine) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextPrevPara) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextNextPara) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextScrollPages) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextTranspose) [list source [file join $dir text.tcl]]\n" "set auto_index(tk_textCopy) [list source [file join $dir text.tcl]]\n" "set auto_index(tk_textCut) [list source [file join $dir text.tcl]]\n" "set auto_index(tk_textPaste) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextNextPos) [list source [file join $dir text.tcl]]\n" "set auto_index(tkTextPrevPos) [list source [file join $dir text.tcl]]\n" "set auto_index(tkScreenChanged) [list source [file join $dir tk.tcl]]\n" "set auto_index(tkEventMotifBindings) [list source [file join $dir tk.tcl]]\n" "set auto_index(tkCancelRepeat) [list source [file join $dir tk.tcl]]\n" "set auto_index(tkTabToWindow) [list source [file join $dir tk.tcl]]\n" "set auto_index(bgerror) [list source [file join $dir bgerror.tcl]]\n" "set auto_index(tkScaleActivate) [list source [file join $dir scale.tcl]]\n" "set auto_index(tkScaleButtonDown) [list source [file join $dir scale.tcl]]\n" "set auto_index(tkScaleDrag) [list source [file join $dir scale.tcl]]\n" "set auto_index(tkScaleEndDrag) [list source [file join $dir scale.tcl]]\n" "set auto_index(tkScaleIncrement) [list source [file join $dir scale.tcl]]\n" "set auto_index(tkScaleControlPress) [list source [file join $dir scale.tcl]]\n" "set auto_index(tkScaleButton2Down) [list source [file join $dir scale.tcl]]\n" "set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]]\n" "set auto_index(tkTearOffMenu) [list source [file join $dir tearoff.tcl]]\n" "set auto_index(tkMenuDup) [list source [file join $dir tearoff.tcl]]\n" "set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]]\n" "set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]]\n" "set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]]\n" "set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]]\n" "set auto_index(tkFocusOK) [list source [file join $dir focus.tcl]]\n" "set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]]\n" "set auto_index(tkConsoleInit) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleSource) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleInvoke) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleHistory) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsolePrompt) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleBind) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleInsert) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleOutput) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleExit) [list source [file join $dir console.tcl]]\n" "set auto_index(tkConsoleAbout) [list source [file join $dir console.tcl]]\n" "set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]]\n" "set auto_index(tkRecolorTree) [list source [file join $dir palette.tcl]]\n" "set auto_index(tkDarken) [list source [file join $dir palette.tcl]]\n" "set auto_index(tk_bisque) [list source [file join $dir palette.tcl]]\n" "set auto_index(tkColorDialog) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_InitValues) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_Config) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_BuildDialog) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_SetRGBValue) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_XToRgb) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_RgbToX) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_DrawColorScale) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_CreateSelector) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_RedrawFinalColor) [list source [file join $dir " "clrpick.tcl]]\n" "set auto_index(tkColorDialog_RedrawColorBars) [list source [file join $dir " "clrpick.tcl]]\n" "set auto_index(tkColorDialog_StartMove) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_MoveSelector) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_ReleaseMouse) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_ResizeColorBars) [list source [file join $dir " "clrpick.tcl]]\n" "set auto_index(tkColorDialog_HandleSelEntry) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_HandleRGBEntry) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_EnterColorBar) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_LeaveColorBar) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_OkCmd) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tkColorDialog_CancelCmd) [list source [file join $dir clrpick.tcl]]\n" "set auto_index(tclParseConfigSpec) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tclListValidFlags) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tclSortNoCase) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tclVerifyInteger) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFocusGroup_Create) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFocusGroup_BindIn) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFocusGroup_BindOut) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFocusGroup_Destroy) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFocusGroup_In) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFocusGroup_Out) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(tkFDGetFileTypes) [list source [file join $dir comdlg.tcl]]\n" "set auto_index(::safe::loadTk) [list source [file join $dir safetk.tcl]]\n" "set auto_index(::safe::TkInit) [list source [file join $dir safetk.tcl]]\n" "set auto_index(::safe::allowTk) [list source [file join $dir safetk.tcl]]\n" "set auto_index(::safe::tkTopLevel) [list source [file join $dir safetk.tcl]]\n" "set auto_index(tkMessageBox) [list source [file join $dir msgbox.tcl]]\n" "set auto_index(tkIconList) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Config) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Create) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_AutoScan) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_DeleteAll) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Add) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Arrange) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Invoke) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_See) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_SelectAtXY) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Select) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Unselect) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Get) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Btn1) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Motion1) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Double1) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_ReturnKey) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Leave1) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_FocusIn) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_UpDown) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_LeftRight) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_KeyPress) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Goto) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkIconList_Reset) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_Config) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_Create) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_UpdateWhenIdle) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_Update) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_SetPathSilently) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_SetPath) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_SetFilter) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialogResolveFile) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_EntFocusIn) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_EntFocusOut) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_ActivateEnt) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_InvokeBtn) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_UpDirCmd) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_JoinFile) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_OkCmd) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_CancelCmd) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_ListBrowse) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_ListInvoke) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkFDialog_Done) [list source [file join $dir tkfbox.tcl]]\n" "set auto_index(tkMotifFDialog) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_Config) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_Create) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_MakeSList) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_BrowseDList) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_ActivateDList) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_BrowseFList) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_ActivateFList) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_ActivateFEnt) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_InterpFilter) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_ActivateSEnt) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_OkCmd) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_FilterCmd) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_CancelCmd) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_Update) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkMotifFDialog_LoadFiles) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkListBoxKeyAccel_Set) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]]\n" "set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]]\n"; struct EtFile { char *zName; char *zData; int nData; int shrouded; struct EtFile *pNext; }; static struct EtFile Et_FileSet[] = { {"C:/cygwin/usr/share/tcl8.0/tclIndex", Et_zFile0, sizeof (Et_zFile0) - 1, 0, 0}, {"C:/cygwin/usr/share/tk8.0/tclIndex", Et_zFile1, sizeof (Et_zFile1) - 1, 0, 0}, {0, 0}}; static struct EtFile *Et_FileHashTable[71]; /* The following copyright notice applies to code generated by ** "mktclapp". The "mktclapp" program itself is covered by the ** GNU Public License. ** ** Copyright (c) 1998 D. Richard Hipp ** ** The author hereby grants permission to use, copy, modify, distribute, ** and license this software and its documentation for any purpose, provided ** that existing copyright notices are retained in all copies and that this ** notice is included verbatim in any distributions. No written agreement, ** license, or royalty fee is required for any of the authorized uses. ** Modifications to this software may be copyrighted by their authors ** and need not follow the licensing terms described here, provided that ** the new terms are clearly indicated on the first page of each file where ** they apply. ** ** In no event shall the author or the distributors be liable to any party ** for direct, indirect, special, incidental, or consequential damages ** arising out of the use of this software, its documentation, or any ** derivatives thereof, even if the author has been advised of the ** possibility of such damage. The author and distributors specifically ** disclaim any warranties, including but not limited to the implied ** warranties of merchantability, fitness for a particular purpose, and ** non-infringment. This software is provided at no fee on an ** "as is" basis. The author and/or distritutors have no obligation ** to provide maintenance, support, updates, enhancements and/or ** modifications. ** ** GOVERNMENT USE: If you are acquiring this software on behalf of the ** U.S. government, the Government shall have only "Restricted Rights" ** in the software and related documentation as defined in the Federal ** Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you ** are acquiring the software on behalf of the Department of Defense, the ** software shall be classified as "Commercial Computer Software" and the ** Government shall have only "Restricted Rights" as defined in Clause ** 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the ** author grants the U.S. Government and others acting in its behalf ** permission to use and distribute the software in accordance with the ** terms specified in this license. */ #include #include #include #include #include #include #include #include /* Include either the Tcl or the Tk header file. Use the "Internal" ** version of the header file if and only if we are generating an ** extension that is linking against the Stub library. ** Many installations do not have the internal header files ** available, so using the internal headers only when absolutely ** necessary will help to reduce compilation problems. */ #if ET_EXTENSION && defined(TCL_USE_STUBS) #if ET_ENABLE_TK #include #else #include #endif #else #if ET_ENABLE_TK #include #else #include #endif #endif /* ** ET_WIN32 is true if we are running Tk under windows. The ** module will define __WIN32__ for us if we are compiling ** for windows. */ #if defined(__WIN32__) && ET_ENABLE_TK #define ET_WIN32 1 #include #else #define ET_WIN32 0 #endif /* ** Always disable ET_AUTO_FORK under windows. Windows doesn't ** fork well. */ #if defined(__WIN32__) #undef ET_AUTO_FORK #define ET_AUTO_FORK 0 #endif /* ** Omit under windows. But we need it for Unix. */ #if !defined(__WIN32__) #include #endif /* ** The Tcl*InsertProc functions allow the system calls "stat", ** "access" and "open" to be overloaded. This in turns allows us ** to substituted compiled-in strings for files in the filesystem. ** But the Tcl*InsertProc functions are only available in Tcl8.0.3 ** and later. ** ** Define the ET_HAVE_INSERTPROC macro if and only if we are dealing ** with Tcl8.0.3 or later. */ #if TCL_MAJOR_VERSION == 8 && (TCL_MINOR_VERSION > 0 || TCL_RELEASE_SERIAL >= 3) #define ET_HAVE_INSERTPROC #endif /* ** If we are using the Tcl*InsertProc() functions, we should provide ** prototypes for them. But the prototypes are in the tclInt.h include ** file, which we don't want to require the user to have on hand. So ** we provide our own prototypes here. ** ** Note that if TCL_USE_STUBS is defined, then the tclInt.h is required ** anyway, so these prototypes are not included if TCL_USE_STUBS is ** defined. */ #if defined(ET_HAVE_INSERTPROC) && !defined(TCL_USE_STUBS) #ifdef __cplusplus extern "C" int TclStatInsertProc (int (*) (char *, struct stat *)); extern "C" int TclAccessInsertProc (int (*) (char *, int)); extern "C" int TclOpenFileChannelInsertProc (Tcl_Channel (*) (Tcl_Interp *, char *, char *, int)); #else extern int TclStatInsertProc (int (*) (char *, struct stat *)); extern int TclAccessInsertProc (int (*) (char *, int)); extern int TclOpenFileChannelInsertProc (Tcl_Channel (*) (Tcl_Interp *, char *, char *, int)); #endif #endif /* ** Don't allow Win32 applications to read from stdin. Nor ** programs that automatically go into the background. Force ** the use of a console in these cases. */ #if (ET_WIN32 || ET_AUTO_FORK) && ET_READ_STDIN #undef ET_READ_STDIN #undef ET_CONSOLE #define ET_READ_STDIN 0 #define ET_CONSOLE 1 #endif /* ** The console won't work without Tk. */ #if ET_ENABLE_TK == 0 && ET_CONSOLE #undef ET_CONSOLE #define ET_CONSOLE 0 #undef ET_READ_STDIN #define ET_READ_STDIN 1 #endif /* ** Set ET_HAVE_OBJ to true if we are able to link against the ** new Tcl_Obj interface. This is only the case for Tcl version ** 8.0 and later. */ #if ET_ENABLE_OBJ || TCL_MAJOR_VERSION >= 8 #define ET_HAVE_OBJ 1 #else #define ET_HAVE_OBJ 0 #endif /* ** The Tcl_GetByteArrayFromObj() only appears in Tcl version 8.1 ** and later. Substitute Tcl_GetStringFromObj() in Tcl version 8.0.X */ #if ET_HAVE_OBJ && TCL_MINOR_VERSION == 0 #define Tcl_GetByteArrayFromObj Tcl_GetStringFromObj #endif /* ** Tcl code to implement the console. ** ** This code is written and tested separately, then run through ** "mktclapp -stringify" and then pasted in here. */ #if ET_ENABLE_TK && !ET_EXTENSION static char zEtConsole[] = "proc console:create {w prompt title} {\n" "upvar #0 $w.t v\n" "if {[winfo exists $w]} {destroy $w}\n" "catch {unset v}\n" "toplevel $w\n" "wm title $w $title\n" "wm iconname $w $title\n" "frame $w.mb -bd 2 -relief raised\n" "pack $w.mb -side top -fill x\n" "menubutton $w.mb.file -text File -menu $w.mb.file.m\n" "menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m\n" "pack $w.mb.file $w.mb.edit -side left -padx 8 -pady 1\n" "set m [menu $w.mb.file.m]\n" "$m add command -label {Source...} -command \"console:SourceFile $w.t\"\n" "$m add command -label {Save As...} -command \"console:SaveFile $w.t\"\n" "$m add separator\n" "$m add command -label {Close} -command \"destroy $w\"\n" "$m add command -label {Exit} -command exit\n" "set m [menu $w.mb.edit.m]\n" "$m add command -label Cut -command \"console:Cut $w.t\"\n" "$m add command -label Copy -command \"console:Copy $w.t\"\n" "$m add command -label Paste -command \"console:Paste $w.t\"\n" "$m add command -label {Clear Screen} -command \"console:Clear $w.t\"\n" "catch {$m config -postcommand \"console:EnableEditMenu $w\"}\n" "scrollbar $w.sb -orient vertical -command \"$w.t yview\"\n" "pack $w.sb -side right -fill y\n" "text $w.t -font fixed -yscrollcommand \"$w.sb set\"\n" "pack $w.t -side right -fill both -expand 1\n" "bindtags $w.t Console\n" "set v(text) $w.t\n" "set v(history) 0\n" "set v(historycnt) 0\n" "set v(current) -1\n" "set v(prompt) $prompt\n" "set v(prior) {}\n" "set v(plength) [string length $v(prompt)]\n" "set v(x) 0\n" "set v(y) 0\n" "$w.t mark set insert end\n" "$w.t tag config ok -foreground blue\n" "$w.t tag config err -foreground red\n" "$w.t insert end $v(prompt)\n" "$w.t mark set out 1.0\n" "catch {rename puts console:oldputs$w}\n" "proc puts args [format {\n" "if {![winfo exists %s]} {\n" "rename puts {}\n" "rename console:oldputs%s puts\n" "return [uplevel #0 puts $args]\n" "}\n" "switch -glob -- \"[llength $args] $args\" {\n" "{1 *} {\n" "set msg [lindex $args 0]\\n\n" "set tag ok\n" "}\n" "{2 stdout *} {\n" "set msg [lindex $args 1]\\n\n" "set tag ok\n" "}\n" "{2 stderr *} {\n" "set msg [lindex $args 1]\\n\n" "set tag err\n" "}\n" "{2 -nonewline *} {\n" "set msg [lindex $args 1]\n" "set tag ok\n" "}\n" "{3 -nonewline stdout *} {\n" "set msg [lindex $args 2]\n" "set tag ok\n" "}\n" "{3 -nonewline stderr *} {\n" "set msg [lindex $args 2]\n" "set tag err\n" "}\n" "default {\n" "uplevel #0 console:oldputs%s $args\n" "return\n" "}\n" "}\n" "console:Puts %s $msg $tag\n" "} $w $w $w $w.t]\n" "after idle \"focus $w.t\"\n" "}\n" "bind Console <1> {console:Button1 %W %x %y}\n" "bind Console {console:B1Motion %W %x %y}\n" "bind Console {console:B1Leave %W %x %y}\n" "bind Console {console:cancelMotor %W}\n" "bind Console {console:cancelMotor %W}\n" "bind Console {console:Insert %W %A}\n" "bind Console {console:Left %W}\n" "bind Console {console:Left %W}\n" "bind Console {console:Right %W}\n" "bind Console {console:Right %W}\n" "bind Console {console:Backspace %W}\n" "bind Console {console:Backspace %W}\n" "bind Console {console:Delete %W}\n" "bind Console {console:Delete %W}\n" "bind Console {console:Home %W}\n" "bind Console {console:Home %W}\n" "bind Console {console:End %W}\n" "bind Console {console:End %W}\n" "bind Console {console:Enter %W}\n" "bind Console {console:Enter %W}\n" "bind Console {console:Prior %W}\n" "bind Console {console:Prior %W}\n" "bind Console {console:Next %W}\n" "bind Console {console:Next %W}\n" "bind Console {console:EraseEOL %W}\n" "bind Console <> {console:Cut %W}\n" "bind Console <> {console:Copy %W}\n" "bind Console <> {console:Paste %W}\n" "bind Console <> {console:Clear %W}\n" "proc console:Puts {w t tag} {\n" "set nc [string length $t]\n" "set endc [string index $t [expr $nc-1]]\n" "if {$endc==\"\\n\"} {\n" "if {[$w index out]<[$w index {insert linestart}]} {\n" "$w insert out [string range $t 0 [expr $nc-2]] $tag\n" "$w mark set out {out linestart +1 lines}\n" "} else {\n" "$w insert out $t $tag\n" "}\n" "} else {\n" "if {[$w index out]<[$w index {insert linestart}]} {\n" "$w insert out $t $tag\n" "} else {\n" "$w insert out $t\\n $tag\n" "$w mark set out {out -1 char}\n" "}\n" "}\n" "$w yview insert\n" "}\n" "proc console:Insert {w a} {\n" "$w insert insert $a\n" "$w yview insert\n" "}\n" "proc console:Left {w} {\n" "upvar #0 $w v\n" "scan [$w index insert] %d.%d row col\n" "if {$col>$v(plength)} {\n" "$w mark set insert \"insert -1c\"\n" "}\n" "}\n" "proc console:Backspace {w} {\n" "upvar #0 $w v\n" "scan [$w index insert] %d.%d row col\n" "if {$col>$v(plength)} {\n" "$w delete {insert -1c}\n" "}\n" "}\n" "proc console:EraseEOL {w} {\n" "upvar #0 $w v\n" "scan [$w index insert] %d.%d row col\n" "if {$col>=$v(plength)} {\n" "$w delete insert {insert lineend}\n" "}\n" "}\n" "proc console:Right {w} {\n" "$w mark set insert \"insert +1c\"\n" "}\n" "proc console:Delete w {\n" "$w delete insert\n" "}\n" "proc console:Home w {\n" "upvar #0 $w v\n" "scan [$w index insert] %d.%d row col\n" "$w mark set insert $row.$v(plength)\n" "}\n" "proc console:End w {\n" "$w mark set insert {insert lineend}\n" "}\n" "proc console:Enter w {\n" "upvar #0 $w v\n" "scan [$w index insert] %d.%d row col\n" "set start $row.$v(plength)\n" "set line [$w get $start \"$start lineend\"]\n" "if {$v(historycnt)>0} {\n" "set last [lindex $v(history) [expr $v(historycnt)-1]]\n" "if {[string compare $last $line]} {\n" "lappend v(history) $line\n" "incr v(historycnt)\n" "}\n" "} else {\n" "set v(history) [list $line]\n" "set v(historycnt) 1\n" "}\n" "set v(current) $v(historycnt)\n" "$w insert end \\n\n" "$w mark set out end\n" "if {$v(prior)==\"\"} {\n" "set cmd $line\n" "} else {\n" "set cmd $v(prior)\\n$line\n" "}\n" "if {[info complete $cmd]} {\n" "set rc [catch {uplevel #0 $cmd} res]\n" "if {![winfo exists $w]} return\n" "if {$rc} {\n" "$w insert end $res\\n err\n" "} elseif {[string length $res]>0} {\n" "$w insert end $res\\n ok\n" "}\n" "set v(prior) {}\n" "$w insert end $v(prompt)\n" "} else {\n" "set v(prior) $cmd\n" "regsub -all {[^ ]} $v(prompt) . x\n" "$w insert end $x\n" "}\n" "$w mark set insert end\n" "$w mark set out {insert linestart}\n" "$w yview insert\n" "}\n" "proc console:Prior w {\n" "upvar #0 $w v\n" "if {$v(current)<=0} return\n" "incr v(current) -1\n" "set line [lindex $v(history) $v(current)]\n" "console:SetLine $w $line\n" "}\n" "proc console:Next w {\n" "upvar #0 $w v\n" "if {$v(current)>=$v(historycnt)} return\n" "incr v(current) 1\n" "set line [lindex $v(history) $v(current)]\n" "console:SetLine $w $line\n" "}\n" "proc console:SetLine {w line} {\n" "upvar #0 $w v\n" "scan [$w index insert] %d.%d row col\n" "set start $row.$v(plength)\n" "$w delete $start end\n" "$w insert end $line\n" "$w mark set insert end\n" "$w yview insert\n" "}\n" "proc console:Button1 {w x y} {\n" "global tkPriv\n" "upvar #0 $w v\n" "set v(mouseMoved) 0\n" "set v(pressX) $x\n" "set p [console:nearestBoundry $w $x $y]\n" "scan [$w index insert] %d.%d ix iy\n" "scan $p %d.%d px py\n" "if {$px==$ix} {\n" "$w mark set insert $p\n" "}\n" "$w mark set anchor $p\n" "focus $w\n" "}\n" "proc console:nearestBoundry {w x y} {\n" "set p [$w index @$x,$y]\n" "set bb [$w bbox $p]\n" "if {![string compare $bb \"\"]} {return $p}\n" "if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}\n" "$w index \"$p + 1 char\"\n" "}\n" "proc console:SelectTo {w x y} {\n" "upvar #0 $w v\n" "set cur [console:nearestBoundry $w $x $y]\n" "if {[catch {$w index anchor}]} {\n" "$w mark set anchor $cur\n" "}\n" "set anchor [$w index anchor]\n" "if {[$w compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {\n" "if {$v(mouseMoved)==0} {\n" "$w tag remove sel 0.0 end\n" "}\n" "set v(mouseMoved) 1\n" "}\n" "if {[$w compare $cur < anchor]} {\n" "set first $cur\n" "set last anchor\n" "} else {\n" "set first anchor\n" "set last $cur\n" "}\n" "if {$v(mouseMoved)} {\n" "$w tag remove sel 0.0 $first\n" "$w tag add sel $first $last\n" "$w tag remove sel $last end\n" "update idletasks\n" "}\n" "}\n" "proc console:B1Motion {w x y} {\n" "upvar #0 $w v\n" "set v(y) $y\n" "set v(x) $x\n" "console:SelectTo $w $x $y\n" "}\n" "proc console:B1Leave {w x y} {\n" "upvar #0 $w v\n" "set v(y) $y\n" "set v(x) $x\n" "console:motor $w\n" "}\n" "proc console:motor w {\n" "upvar #0 $w v\n" "if {![winfo exists $w]} return\n" "if {$v(y)>=[winfo height $w]} {\n" "$w yview scroll 1 units\n" "} elseif {$v(y)<0} {\n" "$w yview scroll -1 units\n" "} else {\n" "return\n" "}\n" "console:SelectTo $w $v(x) $v(y)\n" "set v(timer) [after 50 console:motor $w]\n" "}\n" "proc console:cancelMotor w {\n" "upvar #0 $w v\n" "catch {after cancel $v(timer)}\n" "catch {unset v(timer)}\n" "}\n" "proc console:Copy w {\n" "if {![catch {set text [$w get sel.first sel.last]}]} {\n" "clipboard clear -displayof $w\n" "clipboard append -displayof $w $text\n" "}\n" "}\n" "proc console:canCut w {\n" "set r [catch {\n" "scan [$w index sel.first] %d.%d s1x s1y\n" "scan [$w index sel.last] %d.%d s2x s2y\n" "scan [$w index insert] %d.%d ix iy\n" "}]\n" "if {$r==1} {return 0}\n" "if {$s1x==$ix && $s2x==$ix} {return 1}\n" "return 2\n" "}\n" "proc console:Cut w {\n" "if {[console:canCut $w]==1} {\n" "console:Copy $w\n" "$w delete sel.first sel.last\n" "}\n" "}\n" "proc console:Paste w {\n" "if {[console:canCut $w]==1} {\n" "$w delete sel.first sel.last\n" "}\n" "if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]} {\n" "return\n" "}\n" "set prior 0\n" "foreach line [split $topaste \\n] {\n" "if {$prior} {\n" "console:Enter $w\n" "update\n" "}\n" "set prior 1\n" "$w insert insert $line\n" "}\n" "}\n" "proc console:EnableEditMenu w {\n" "set m $w.mb.edit.m\n" "switch [console:canCut $w.t] {\n" "0 {\n" "$m entryconf Copy -state disabled\n" "$m entryconf Cut -state disabled\n" "}\n" "1 {\n" "$m entryconf Copy -state normal\n" "$m entryconf Cut -state normal\n" "}\n" "2 {\n" "$m entryconf Copy -state normal\n" "$m entryconf Cut -state disabled\n" "}\n" "}\n" "}\n" "proc console:SourceFile w {\n" "set types {\n" "{{TCL Scripts} {.tcl}}\n" "{{All Files} *}\n" "}\n" "set f [tk_getOpenFile -filetypes $types -title \"TCL Script To Source...\"]\n" "if {$f!=\"\"} {\n" "uplevel #0 source $f\n" "}\n" "}\n" "proc console:SaveFile w {\n" "set types {\n" "{{Text Files} {.txt}}\n" "{{All Files} *}\n" "}\n" "set f [tk_getSaveFile -filetypes $types -title \"Write Screen To...\"]\n" "if {$f!=\"\"} {\n" "if {[catch {open $f w} fd]} {\n" "tk_messageBox -type ok -icon error -message $fd\n" "} else {\n" "puts $fd [string trimright [$w get 1.0 end] \\n]\n" "close $fd\n" "}\n" "}\n" "}\n" "proc console:Clear w {\n" "$w delete 1.0 {insert linestart}\n" "}\n"; /* End of the console code */ #endif /* ET_ENABLE_TK */ /* ** The "printf" code that follows dates from the 1980's. It is in ** the public domain. The original comments are included here for ** completeness. They are slightly out-of-date. ** ** The following modules is an enhanced replacement for the "printf" programs ** found in the standard library. The following enhancements are ** supported: ** ** + Additional functions. The standard set of "printf" functions ** includes printf, fprintf, sprintf, vprintf, vfprintf, and ** vsprintf. This module adds the following: ** ** * snprintf -- Works like sprintf, but has an extra argument ** which is the size of the buffer written to. ** ** * mprintf -- Similar to sprintf. Writes output to memory ** obtained from malloc. ** ** * xprintf -- Calls a function to dispose of output. ** ** * nprintf -- No output, but returns the number of characters ** that would have been output by printf. ** ** * A v- version (ex: vsnprintf) of every function is also ** supplied. ** ** + A few extensions to the formatting notation are supported: ** ** * The "=" flag (similar to "-") causes the output to be ** be centered in the appropriately sized field. ** ** * The %b field outputs an integer in binary notation. ** ** * The %c field now accepts a precision. The character output ** is repeated by the number of times the precision specifies. ** ** * The %' field works like %c, but takes as its character the ** next character of the format string, instead of the next ** argument. For example, printf("%.78'-") prints 78 minus ** signs, the same as printf("%.78c",'-'). ** ** + When compiled using GCC on a SPARC, this version of printf is ** faster than the library printf for SUN OS 4.1. ** ** + All functions are fully reentrant. ** */ /* ** Undefine COMPATIBILITY to make some slight changes in the way things ** work. I think the changes are an improvement, but they are not ** backwards compatible. */ /* #define COMPATIBILITY / * Compatible with SUN OS 4.1 */ /* ** Characters that need to be escaped inside a TCL string. */ static char NeedEsc[] = { 1, 1, 1, 1, 1, 1, 1, 1, 'b', 't', 'n', 1, 'f', 'r', 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, '"', 0, '$', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, '[', '\\', ']', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, }; /* ** Conversion types fall into various categories as defined by the ** following enumeration. */ enum et_type { /* The type of the format field */ etRADIX, /* Integer types. %d, %x, %o, and so forth */ etFLOAT, /* Floating point. %f */ etEXP, /* Exponentional notation. %e and %E */ etGENERIC, /* Floating or exponential, depending on exponent. %g */ etSIZE, /* Return number of characters processed so far. %n */ etSTRING, /* Strings. %s */ etPERCENT, /* Percent symbol. %% */ etCHARX, /* Characters. %c */ etERROR, /* Used to indicate no such conversion type */ /* The rest are extensions, not normally found in printf() */ etCHARLIT, /* Literal characters. %' */ etTCLESCAPE, /* Strings with special characters escaped. %q */ etMEMSTRING, /* A string which should be deleted after use. %z */ etORDINAL /* 1st, 2nd, 3rd and so forth */ }; /* ** Each builtin conversion character (ex: the 'd' in "%d") is described ** by an instance of the following structure */ typedef struct et_info { /* Information about each format field */ int fmttype; /* The format field code letter */ int base; /* The base for radix conversion */ char *charset; /* The character set for conversion */ int flag_signed; /* Is the quantity signed? */ char *prefix; /* Prefix on non-zero values in alt format */ enum et_type type; /* Conversion paradigm */ } et_info; /* ** The following table is searched linearly, so it is good to put the ** most frequently used conversion types first. */ static et_info fmtinfo[] = { { 'd', 10, "0123456789", 1, 0, etRADIX, }, { 's', 0, 0, 0, 0, etSTRING, }, { 'q', 0, 0, 0, 0, etTCLESCAPE, }, { 'z', 0, 0, 0, 0, etMEMSTRING, }, { 'c', 0, 0, 0, 0, etCHARX, }, { 'o', 8, "01234567", 0, "0", etRADIX, }, { 'u', 10, "0123456789", 0, 0, etRADIX, }, { 'x', 16, "0123456789abcdef", 0, "x0", etRADIX, }, { 'X', 16, "0123456789ABCDEF", 0, "X0", etRADIX, }, { 'r', 10, "0123456789", 0, 0, etORDINAL, }, { 'f', 0, 0, 1, 0, etFLOAT, }, { 'e', 0, "e", 1, 0, etEXP, }, { 'E', 0, "E", 1, 0, etEXP, }, { 'g', 0, "e", 1, 0, etGENERIC, }, { 'G', 0, "E", 1, 0, etGENERIC, }, { 'i', 10, "0123456789", 1, 0, etRADIX, }, { 'n', 0, 0, 0, 0, etSIZE, }, { '%', 0, 0, 0, 0, etPERCENT, }, { 'b', 2, "01", 0, "b0", etRADIX, }, /* Binary */ { 'p', 10, "0123456789", 0, 0, etRADIX, }, /* Pointers */ { '\'', 0, 0, 0, 0, etCHARLIT, }, /* Literal char */ }; #define etNINFO (sizeof (fmtinfo) / sizeof (fmtinfo[0])) /* ** If NOFLOATINGPOINT is defined, then none of the floating point ** conversions will work. */ #ifndef etNOFLOATINGPOINT /* ** "*val" is a double such that 0.1 <= *val < 10.0 ** Return the ascii code for the leading digit of *val, then ** multiply "*val" by 10.0 to renormalize. ** ** Example: ** input: *val = 3.14159 ** output: *val = 1.4159 function return = '3' ** ** The counter *cnt is incremented each time. After counter exceeds ** 16 (the number of significant digits in a 64-bit float) '0' is ** always returned. */ static int et_getdigit (double *val, int *cnt) { int digit; double d; if ((*cnt)++ >= 16) return '0'; digit = (int) *val; d = digit; digit += '0'; *val = (*val - d) * 10.0; return digit; } #endif #define etBUFSIZE 1000 /* Size of the output buffer */ /* ** The root program. All variations call this core. ** ** INPUTS: ** func This is a pointer to a function taking three arguments ** 1. A pointer to anything. Same as the "arg" parameter. ** 2. A pointer to the list of characters to be output ** (Note, this list is NOT null terminated.) ** 3. An integer number of characters to be output. ** (Note: This number might be zero.) ** ** arg This is the pointer to anything which will be passed as the ** first argument to "func". Use it for whatever you like. ** ** fmt This is the format string, as in the usual print. ** ** ap This is a pointer to a list of arguments. Same as in ** vfprint. ** ** OUTPUTS: ** The return value is the total number of characters sent to ** the function "func". Returns -1 on a error. ** ** Note that the order in which automatic variables are declared below ** seems to make a big difference in determining how fast this beast ** will run. */ int vxprintf (void (*func) (void *, char *, int), void *arg, const char *format, va_list ap) { register const char *fmt; /* The format string. */ register int c; /* Next character in the format string */ register char *bufpt; /* Pointer to the conversion buffer */ register int precision; /* Precision of the current field */ register int length; /* Length of the field */ register int idx; /* A general purpose loop counter */ int count; /* Total number of characters output */ int width; /* Width of the current field */ int flag_leftjustify; /* True if "-" flag is present */ int flag_plussign; /* True if "+" flag is present */ int flag_blanksign; /* True if " " flag is present */ int flag_alternateform; /* True if "#" flag is present */ int flag_zeropad; /* True if field width constant starts with zero */ int flag_long; /* True if "l" flag is present */ int flag_center; /* True if "=" flag is present */ unsigned long longvalue; /* Value for integer types */ double realvalue; /* Value for real types */ et_info *infop; /* Pointer to the appropriate info structure */ char buf[etBUFSIZE]; /* Conversion buffer */ char prefix; /* Prefix character. "+" or "-" or " " or '\0'. */ int errorflag = 0; /* True if an error is encountered */ enum et_type xtype; /* Conversion paradigm */ char *zMem; /* String to be freed */ char *zExtra; /* Extra memory used for etTCLESCAPE conversions */ static char spaces[] = " " " " " "; #define etSPACESIZE (sizeof (spaces) - 1) #ifndef etNOFLOATINGPOINT int exp; /* exponent of real numbers */ double rounder; /* Used for rounding floating point values */ int flag_dp; /* True if decimal point should be shown */ int flag_rtz; /* True if trailing zeros should be removed */ int flag_exp; /* True to force display of the exponent */ int nsd; /* Number of significant digits returned */ #endif fmt = format; /* Put in a register for speed */ count = length = 0; bufpt = 0; for (; (c = (*fmt)) != 0; ++fmt) { if (c != '%') { register int amt; bufpt = (char *) fmt; amt = 1; while ((c = (*++fmt)) != '%' && c != 0) amt++; (*func) (arg, bufpt, amt); count += amt; if (c == 0) break; } if ((c = (*++fmt)) == 0) { errorflag = 1; (*func) (arg, "%", 1); count++; break; } /* Find out what flags are present */ flag_leftjustify = flag_plussign = flag_blanksign = flag_alternateform = flag_zeropad = flag_center = 0; do { switch (c) { case '-': flag_leftjustify = 1; c = 0; break; case '+': flag_plussign = 1; c = 0; break; case ' ': flag_blanksign = 1; c = 0; break; case '#': flag_alternateform = 1; c = 0; break; case '0': flag_zeropad = 1; c = 0; break; case '=': flag_center = 1; c = 0; break; default: break; } } while (c == 0 && (c = (*++fmt)) != 0); if (flag_center) flag_leftjustify = 0; /* Get the field width */ width = 0; if (c == '*') { width = va_arg (ap, int); if (width < 0) { flag_leftjustify = 1; width = -width; } c = *++fmt; } else { while (isdigit (c)) { width = width * 10 + c - '0'; c = *++fmt; } } if (width > etBUFSIZE - 10) { width = etBUFSIZE - 10; } /* Get the precision */ if (c == '.') { precision = 0; c = *++fmt; if (c == '*') { precision = va_arg (ap, int); #ifndef etCOMPATIBILITY /* This is sensible, but SUN OS 4.1 doesn't do it. */ if (precision < 0) precision = -precision; #endif c = *++fmt; } else { while (isdigit (c)) { precision = precision * 10 + c - '0'; c = *++fmt; } } /* Limit the precision to prevent overflowing buf[] during conversion */ if (precision > etBUFSIZE - 40) precision = etBUFSIZE - 40; } else { precision = -1; } /* Get the conversion type modifier */ if (c == 'l') { flag_long = 1; c = *++fmt; } else { flag_long = 0; } /* Fetch the info entry for the field */ infop = 0; for (idx = 0; idx < etNINFO; idx++) { if (c == fmtinfo[idx].fmttype) { infop = &fmtinfo[idx]; break; } } /* No info entry found. It must be an error. */ if (infop == 0) { xtype = etERROR; } else { xtype = infop->type; } zExtra = 0; /* ** At this point, variables are initialized as follows: ** ** flag_alternateform TRUE if a '#' is present. ** flag_plussign TRUE if a '+' is present. ** flag_leftjustify TRUE if a '-' is present or if the ** field width was negative. ** flag_zeropad TRUE if the width began with 0. ** flag_long TRUE if the letter 'l' (ell) prefixed ** the conversion character. ** flag_blanksign TRUE if a ' ' is present. ** width The specified field width. This is ** always non-negative. Zero is the default. ** precision The specified precision. The default ** is -1. ** xtype The class of the conversion. ** infop Pointer to the appropriate info struct. */ switch (xtype) { case etORDINAL: case etRADIX: if (flag_long) longvalue = va_arg (ap, long); else longvalue = va_arg (ap, int); #ifdef etCOMPATIBILITY /* For the format %#x, the value zero is printed "0" not "0x0". ** I think this is stupid. */ if (longvalue == 0) flag_alternateform = 0; #else /* More sensible: turn off the prefix for octal (to prevent "00"), ** but leave the prefix for hex. */ if (longvalue == 0 && infop->base == 8) flag_alternateform = 0; #endif if (infop->flag_signed) { if (*(long *) &longvalue < 0) { longvalue = -*(long *) &longvalue; prefix = '-'; } else if (flag_plussign) prefix = '+'; else if (flag_blanksign) prefix = ' '; else prefix = 0; } else prefix = 0; if (flag_zeropad && precision < width - (prefix != 0)) { precision = width - (prefix != 0); } bufpt = &buf[etBUFSIZE]; if (xtype == etORDINAL) { long a, b; a = longvalue % 10; b = longvalue % 100; bufpt -= 2; if (a == 0 || a > 3 || (b > 10 && b < 14)) { bufpt[0] = 't'; bufpt[1] = 'h'; } else if (a == 1) { bufpt[0] = 's'; bufpt[1] = 't'; } else if (a == 2) { bufpt[0] = 'n'; bufpt[1] = 'd'; } else if (a == 3) { bufpt[0] = 'r'; bufpt[1] = 'd'; } } { register char *cset; /* Use registers for speed */ register int base; cset = infop->charset; base = infop->base; do { /* Convert to ascii */ *(--bufpt) = cset[longvalue % base]; longvalue = longvalue / base; } while (longvalue > 0); } length = (long) &buf[etBUFSIZE] - (long) bufpt; for (idx = precision - length; idx > 0; idx--) { *(--bufpt) = '0'; /* Zero pad */ } if (prefix) *(--bufpt) = prefix; /* Add sign */ if (flag_alternateform && infop->prefix) { /* Add "0" or "0x" */ char *pre, x; pre = infop->prefix; if (*bufpt != pre[0]) { for (pre = infop->prefix; (x = (*pre)) != 0; pre++) *(--bufpt) = x; } } length = (long) &buf[etBUFSIZE] - (long) bufpt; break; case etFLOAT: case etEXP: case etGENERIC: realvalue = va_arg (ap, double); #ifndef etNOFLOATINGPOINT if (precision < 0) precision = 6; /* Set default precision */ if (precision > etBUFSIZE - 10) precision = etBUFSIZE - 10; if (realvalue < 0.0) { realvalue = -realvalue; prefix = '-'; } else { if (flag_plussign) prefix = '+'; else if (flag_blanksign) prefix = ' '; else prefix = 0; } if (infop->type == etGENERIC && precision > 0) precision--; rounder = 0.0; #ifdef COMPATIBILITY /* Rounding works like BSD when the constant 0.4999 is used. Wierd! */ for (idx = precision, rounder = 0.4999; idx > 0; idx--, rounder *= 0.1) ; #else /* It makes more sense to use 0.5 */ for (idx = precision, rounder = 0.5; idx > 0; idx--, rounder *= 0.1) ; #endif if (infop->type == etFLOAT) realvalue += rounder; /* Normalize realvalue to within 10.0 > realvalue >= 1.0 */ exp = 0; if (realvalue > 0.0) { int k = 0; while (realvalue >= 1e8 && k++ < 100) { realvalue *= 1e-8; exp += 8; } while (realvalue >= 10.0 && k++ < 100) { realvalue *= 0.1; exp++; } while (realvalue < 1e-8 && k++ < 100) { realvalue *= 1e8; exp -= 8; } while (realvalue < 1.0 && k++ < 100) { realvalue *= 10.0; exp--; } if (k >= 100) { bufpt = "NaN"; length = 3; break; } } bufpt = buf; /* ** If the field type is etGENERIC, then convert to either etEXP ** or etFLOAT, as appropriate. */ flag_exp = xtype == etEXP; if (xtype != etFLOAT) { realvalue += rounder; if (realvalue >= 10.0) { realvalue *= 0.1; exp++; } } if (xtype == etGENERIC) { flag_rtz = !flag_alternateform; if (exp < -4 || exp > precision) { xtype = etEXP; } else { precision = precision - exp; xtype = etFLOAT; } } else { flag_rtz = 0; } /* ** The "exp+precision" test causes output to be of type etEXP if ** the precision is too large to fit in buf[]. */ nsd = 0; if (xtype == etFLOAT && exp + precision < etBUFSIZE - 30) { flag_dp = (precision > 0 || flag_alternateform); if (prefix) *(bufpt++) = prefix; /* Sign */ if (exp < 0) *(bufpt++) = '0'; /* Digits before "." */ else for (; exp >= 0; exp--) *(bufpt++) = et_getdigit (&realvalue, &nsd); if (flag_dp) *(bufpt++) = '.'; /* The decimal point */ for (exp++; exp < 0 && precision > 0; precision--, exp++) { *(bufpt++) = '0'; } while ((precision--) > 0) *(bufpt++) = et_getdigit (&realvalue, &nsd); *(bufpt--) = 0; /* Null terminate */ if (flag_rtz && flag_dp) { /* Remove trailing zeros and "." */ while (bufpt >= buf && *bufpt == '0') *(bufpt--) = 0; if (bufpt >= buf && *bufpt == '.') *(bufpt--) = 0; } bufpt++; /* point to next free slot */ } else { /* etEXP or etGENERIC */ flag_dp = (precision > 0 || flag_alternateform); if (prefix) *(bufpt++) = prefix; /* Sign */ *(bufpt++) = et_getdigit (&realvalue, &nsd); /* First digit */ if (flag_dp) *(bufpt++) = '.'; /* Decimal point */ while ((precision--) > 0) *(bufpt++) = et_getdigit (&realvalue, &nsd); bufpt--; /* point to last digit */ if (flag_rtz && flag_dp) { /* Remove tail zeros */ while (bufpt >= buf && *bufpt == '0') *(bufpt--) = 0; if (bufpt >= buf && *bufpt == '.') *(bufpt--) = 0; } bufpt++; /* point to next free slot */ if (exp || flag_exp) { *(bufpt++) = infop->charset[0]; if (exp < 0) { *(bufpt++) = '-'; exp = -exp; } /* sign of exp */ else { *(bufpt++) = '+'; } if (exp >= 100) { *(bufpt++) = (exp / 100) + '0'; /* 100's digit */ exp %= 100; } *(bufpt++) = exp / 10 + '0'; /* 10's digit */ *(bufpt++) = exp % 10 + '0'; /* 1's digit */ } } /* The converted number is in buf[] and zero terminated. Output it. ** Note that the number is in the usual order, not reversed as with ** integer conversions. */ length = (long) bufpt - (long) buf; bufpt = buf; /* Special case: Add leading zeros if the flag_zeropad flag is ** set and we are not left justified */ if (flag_zeropad && !flag_leftjustify && length < width) { int i; int nPad = width - length; for (i = width; i >= nPad; i--) { bufpt[i] = bufpt[i - nPad]; } i = prefix != 0; while (nPad--) bufpt[i++] = '0'; length = width; } #endif break; case etSIZE: *(va_arg (ap, int *)) = count; length = width = 0; break; case etPERCENT: buf[0] = '%'; bufpt = buf; length = 1; break; case etCHARLIT: case etCHARX: c = buf[0] = (xtype == etCHARX ? va_arg (ap, int) : *++fmt); if (precision >= 0) { for (idx = 1; idx < precision; idx++) buf[idx] = c; length = precision; } else { length = 1; } bufpt = buf; break; case etSTRING: case etMEMSTRING: zMem = bufpt = va_arg (ap, char *); if (bufpt == 0) bufpt = "(null)"; length = strlen (bufpt); if (precision >= 0 && precision < length) length = precision; break; case etTCLESCAPE: { int i, j, n, c, k; char *arg = va_arg (ap, char *); if (arg == 0) arg = "(NULL)"; for (i = n = 0; (c = arg[i]) != 0; i++) { k = NeedEsc[c & 0xff]; if (k == 0) { n++; } else if (k == 1) { n += 4; } else { n += 2; } } n++; if (n > etBUFSIZE) { bufpt = zExtra = Tcl_Alloc (n); } else { bufpt = buf; } for (i = j = 0; (c = arg[i]) != 0; i++) { k = NeedEsc[c & 0xff]; if (k == 0) { bufpt[j++] = c; } else if (k == 1) { bufpt[j++] = '\\'; bufpt[j++] = ((c >> 6) & 3) + '0'; bufpt[j++] = ((c >> 3) & 7) + '0'; bufpt[j++] = (c & 7) + '0'; } else { bufpt[j++] = '\\'; bufpt[j++] = k; } } bufpt[j] = 0; length = j; if (precision >= 0 && precision < length) length = precision; } break; case etERROR: buf[0] = '%'; buf[1] = c; errorflag = 0; idx = 1 + (c != 0); (*func) (arg, "%", idx); count += idx; if (c == 0) fmt--; break; } /* End switch over the format type */ /* ** The text of the conversion is pointed to by "bufpt" and is ** "length" characters long. The field width is "width". Do ** the output. */ if (!flag_leftjustify) { register int nspace; nspace = width - length; if (nspace > 0) { if (flag_center) { nspace = nspace / 2; width -= nspace; flag_leftjustify = 1; } count += nspace; while (nspace >= etSPACESIZE) { (*func) (arg, spaces, etSPACESIZE); nspace -= etSPACESIZE; } if (nspace > 0) (*func) (arg, spaces, nspace); } } if (length > 0) { (*func) (arg, bufpt, length); count += length; } if (xtype == etMEMSTRING && zMem) { Tcl_Free (zMem); } if (flag_leftjustify) { register int nspace; nspace = width - length; if (nspace > 0) { count += nspace; while (nspace >= etSPACESIZE) { (*func) (arg, spaces, etSPACESIZE); nspace -= etSPACESIZE; } if (nspace > 0) (*func) (arg, spaces, nspace); } } if (zExtra) { Tcl_Free (zExtra); } } /* End for loop over the format string */ return errorflag ? -1 : count; } /* End of function */ /* ** The following section of code handles the mprintf routine, that ** writes to memory obtained from malloc(). */ /* This structure is used to store state information about the ** write to memory that is currently in progress. */ struct sgMprintf { char *zBase; /* A base allocation */ char *zText; /* The string collected so far */ int nChar; /* Length of the string so far */ int nAlloc; /* Amount of space allocated in zText */ }; /* ** The xprintf callback function. ** ** This routine add nNewChar characters of text in zNewText to ** the sgMprintf structure pointed to by "arg". */ static void mout (void *arg, char *zNewText, int nNewChar) { struct sgMprintf *pM = (struct sgMprintf *) arg; if (pM->nChar + nNewChar + 1 > pM->nAlloc) { pM->nAlloc = pM->nChar + nNewChar * 2 + 1; if (pM->zText == pM->zBase) { pM->zText = Tcl_Alloc (pM->nAlloc); if (pM->zText && pM->nChar) memcpy (pM->zText, pM->zBase, pM->nChar); } else { pM->zText = Tcl_Realloc (pM->zText, pM->nAlloc); } } if (pM->zText) { memcpy (&pM->zText[pM->nChar], zNewText, nNewChar); pM->nChar += nNewChar; pM->zText[pM->nChar] = 0; } } /* ** mprintf() works like printf(), but allocations memory to hold the ** resulting string and returns a pointer to the allocated memory. */ char *mprintf (const char *zFormat, ...) { va_list ap; struct sgMprintf sMprintf; char *zNew; char zBuf[200]; sMprintf.nChar = 0; sMprintf.nAlloc = sizeof (zBuf); sMprintf.zText = zBuf; sMprintf.zBase = zBuf; va_start (ap, zFormat); vxprintf (mout, &sMprintf, zFormat, ap); va_end (ap); sMprintf.zText[sMprintf.nChar] = 0; if (sMprintf.zText == sMprintf.zBase) { zNew = Tcl_Alloc (sMprintf.nChar + 1); if (zNew) strcpy (zNew, zBuf); } else { zNew = Tcl_Realloc (sMprintf.zText, sMprintf.nChar + 1); } return zNew; } /* This is the varargs version of mprintf. */ char *vmprintf (const char *zFormat, va_list ap) { struct sgMprintf sMprintf; char zBuf[200]; sMprintf.nChar = 0; sMprintf.zText = zBuf; sMprintf.nAlloc = sizeof (zBuf); sMprintf.zBase = zBuf; vxprintf (mout, &sMprintf, zFormat, ap); sMprintf.zText[sMprintf.nChar] = 0; if (sMprintf.zText == sMprintf.zBase) { sMprintf.zText = Tcl_Alloc (strlen (zBuf) + 1); if (sMprintf.zText) strcpy (sMprintf.zText, zBuf); } else { sMprintf.zText = Tcl_Realloc (sMprintf.zText, sMprintf.nChar + 1); } return sMprintf.zText; } /* ** Add text output to a Tcl_DString. ** ** This routine is called by vxprintf(). It's job is to add ** nNewChar characters of text from zNewText to the Tcl_DString ** that "arg" is pointing to. */ static void dstringout (void *arg, char *zNewText, int nNewChar) { Tcl_DString *str = (Tcl_DString *) arg; Tcl_DStringAppend (str, zNewText, nNewChar); } /* ** Append formatted output to a DString. */ char *Et_DStringAppendF (Tcl_DString *str, const char *zFormat, ...) { va_list ap; va_start (ap, zFormat); vxprintf (dstringout, str, zFormat, ap); va_end (ap); return Tcl_DStringValue (str); } /* ** Make this variable true to trace all calls to EvalF */ int Et_EvalTrace = 0; /* ** Eval the results of a string. */ int Et_EvalF (Tcl_Interp *interp, const char *zFormat, ...) { char *zCmd; va_list ap; int result; va_start (ap, zFormat); zCmd = vmprintf (zFormat, ap); if (Et_EvalTrace) printf ("%s\n", zCmd); result = Tcl_Eval (interp, zCmd); if (Et_EvalTrace) printf ("%d %s\n", result, interp->result); Tcl_Free (zCmd); return result; } int Et_GlobalEvalF (Tcl_Interp *interp, const char *zFormat, ...) { char *zCmd; va_list ap; int result; va_start (ap, zFormat); zCmd = vmprintf (zFormat, ap); if (Et_EvalTrace) printf ("%s\n", zCmd); result = Tcl_GlobalEval (interp, zCmd); if (Et_EvalTrace) printf ("%d %s\n", result, interp->result); Tcl_Free (zCmd); return result; } /* ** Set the result of an interpreter using printf-like arguments. */ void Et_ResultF (Tcl_Interp *interp, const char *zFormat, ...) { Tcl_DString str; va_list ap; Tcl_DStringInit (&str); va_start (ap, zFormat); vxprintf (dstringout, &str, zFormat, ap); va_end (ap); Tcl_DStringResult (interp, &str); } #if ET_HAVE_OBJ /* ** Append text to a string object. */ int Et_AppendObjF (Tcl_Obj *pObj, const char *zFormat, ...) { va_list ap; int rc; va_start (ap, zFormat); rc = vxprintf ((void (*) (void *, char *, int)) Tcl_AppendToObj, pObj, zFormat, ap); va_end (ap); return rc; } #endif #if ET_WIN32 /* ** This array translates all characters into themselves. Except ** for the \ which gets translated into /. And all upper-case ** characters are translated into lower case. This is used for ** hashing and comparing filenames, to work around the Windows ** bug of ignoring filename case and using the wrong separator ** character for directories. ** ** The array is initialized by FilenameHashInit(). ** ** We also define a macro ET_TRANS() that actually does ** the character translation. ET_TRANS() is a no-op under ** unix. */ static char charTrans[256]; #define ET_TRANS(X) (charTrans[0xff & (int) (X)]) #else #define ET_TRANS(X) (X) #endif /* ** Hash a filename. The value returned is appropriate for ** indexing into the Et_FileHashTable[] array. */ static int FilenameHash (char *zName) { int h = 0; while (*zName) { h = h ^ (h << 5) ^ ET_TRANS (*(zName++)); } if (h < 0) h = -h; return h % (sizeof (Et_FileHashTable) / sizeof (Et_FileHashTable[0])); } /* ** Compare two filenames. Return 0 if they are the same and ** non-zero if they are different. */ static int FilenameCmp (char *z1, char *z2) { int diff; while ((diff = ET_TRANS (*z1) - ET_TRANS (*z2)) == 0 && *z1 != 0) { z1++; z2++; } return diff; } /* ** Initialize the file hash table */ static void FilenameHashInit (void) { int i; #if ET_WIN32 for (i = 0; i < sizeof (charTrans); i++) { charTrans[i] = i; } for (i = 'A'; i <= 'Z'; i++) { charTrans[i] = i + 'a' - 'A'; } charTrans['\\'] = '/'; #endif for (i = 0; i < sizeof (Et_FileSet) / sizeof (Et_FileSet[0]) - 1; i++) { struct EtFile *p; int h; p = &Et_FileSet[i]; h = FilenameHash (p->zName); p->pNext = Et_FileHashTable[h]; Et_FileHashTable[h] = p; } } /* ** Locate the text of a built-in file given its name. ** Return 0 if not found. Return this size of the file (not ** counting the null-terminator) in *pSize if pSize!=NULL. ** ** If deshroud==1 and the file is shrouded, then descramble ** the text. */ static char *FindBuiltinFile (char *zName, int deshroud, int *pSize) { int h; struct EtFile *p; h = FilenameHash (zName); p = Et_FileHashTable[h]; while (p && FilenameCmp (p->zName, zName) != 0) { p = p->pNext; } #if ET_SHROUD_KEY > 0 if (p && p->shrouded && deshroud) { char *z; int xor = ET_SHROUD_KEY; for (z = p->zData; *z; z++) { if (*z >= 0x20) { *z ^= xor; xor = (xor+1) & 0x1f; } } p->shrouded = 0; } #endif if (p && pSize) { *pSize = p->nData; } return p ? p->zData : 0; } /* ** Add a new file to the list of built-in files. ** ** This routine makes a copy of zFilename. But it does NOT make ** a copy of zData. It just holds a pointer to zData and uses ** that for all file access. So after calling this routine, ** you should never change zData! */ void Et_NewBuiltinFile ( char *zFilename, /* Name of the new file */ char *zData, /* Data for the new file */ int nData /* Number of bytes in the new file */ ) { int h; struct EtFile *p; p = (struct EtFile *) Tcl_Alloc (sizeof (struct EtFile) + strlen (zFilename) + 1); if (p == 0) return; p->zName = (char *) &p[1]; strcpy (p->zName, zFilename); p->zData = zData; p->nData = nData; p->shrouded = 0; h = FilenameHash (zFilename); p->pNext = Et_FileHashTable[h]; Et_FileHashTable[h] = p; } /* ** A TCL interface to the Et_NewBuiltinFile function. For Tcl8.0 ** and later, we make this an Obj command so that it can deal with ** binary data. */ #if ET_HAVE_OBJ static int Et_NewBuiltinFileCmd (ET_OBJARGS) { char *zData, *zNew; int nData; if (objc != 3) { Tcl_WrongNumArgs (interp, 1, objv, "filename data"); return TCL_ERROR; } zData = (char *) Tcl_GetByteArrayFromObj (objv[2], &nData); zNew = Tcl_Alloc (nData + 1); if (zNew) { memcpy (zNew, zData, nData); zNew[nData] = 0; Et_NewBuiltinFile (Tcl_GetStringFromObj (objv[1], 0), zNew, nData); } return TCL_OK; } #else static int Et_NewBuiltinFileCmd (ET_TCLARGS) { char *zData; int nData; if (argc != 3) { Et_ResultF (interp, "wrong # args: should be \"%s FILENAME DATA\"", argv[0]); return TCL_ERROR; } nData = strlen (argv[2]) + 1; zData = Tcl_Alloc (nData); if (zData) { strcpy (zData, argv[2]); Et_NewBuiltinFile (argv[1], zData, nData); } return TCL_OK; } #endif /* ** The following section implements the InsertProc functionality. The ** new InsertProc feature of Tcl8.0.3 and later allows us to overload ** the usual system call commands for file I/O and replace them with ** commands that operate on the built-in files. */ #ifdef ET_HAVE_INSERTPROC /* ** Each open channel to a built-in file is an instance of the ** following structure. */ typedef struct Et_FileStruct { char *zData; /* All of the data */ int nData; /* Bytes of data, not counting the null terminator */ int cursor; /* How much of the data has been read so far */ } Et_FileStruct; /* ** Close a previously opened built-in file. */ static int Et_FileClose (ClientData instanceData, Tcl_Interp *interp) { Et_FileStruct *p = (Et_FileStruct *) instanceData; Tcl_Free ((char *) p); return 0; } /* ** Read from a built-in file. */ static int Et_FileInput ( ClientData instanceData, /* The file structure */ char *buf, /* Write the data read here */ int bufSize, /* Read this much data */ int *pErrorCode /* Write the error code here */ ) { Et_FileStruct *p = (Et_FileStruct *) instanceData; *pErrorCode = 0; if (p->cursor + bufSize > p->nData) { bufSize = p->nData - p->cursor; } memcpy (buf, &p->zData[p->cursor], bufSize); p->cursor += bufSize; return bufSize; } /* ** Writes to a built-in file always return EOF. */ static int Et_FileOutput ( ClientData instanceData, /* The file structure */ char *buf, /* Read the data from here */ int toWrite, /* Write this much data */ int *pErrorCode /* Write the error code here */ ) { *pErrorCode = 0; return 0; } /* ** Move the cursor around within the built-in file. */ static int Et_FileSeek ( ClientData instanceData, /* The file structure */ long offset, /* Offset to seek to */ int mode, /* One of SEEK_CUR, SEEK_SET or SEEK_END */ int *pErrorCode /* Write the error code here */ ) { Et_FileStruct *p = (Et_FileStruct *) instanceData; switch (mode) { case SEEK_CUR: offset += p->cursor; break; case SEEK_END: offset += p->nData; break; default: break; } if (offset < 0) offset = 0; if (offset > p->nData) offset = p->nData; p->cursor = offset; return offset; } /* ** The Watch method is a no-op */ static void Et_FileWatch (ClientData instanceData, int mask) { } /* ** The Handle method always returns an error. */ static int Et_FileHandle (ClientData notUsed, int dir, ClientData *handlePtr) { return TCL_ERROR; } /* ** This is the channel type that will access the built-in files. */ static Tcl_ChannelType builtinChannelType = { "builtin", /* Type name. */ NULL, /* Always non-blocking.*/ Et_FileClose, /* Close proc. */ Et_FileInput, /* Input proc. */ Et_FileOutput, /* Output proc. */ Et_FileSeek, /* Seek proc. */ NULL, /* Set option proc. */ NULL, /* Get option proc. */ Et_FileWatch, /* Watch for events on console. */ Et_FileHandle, /* Get a handle from the device. */ }; /* ** This routine attempts to do an open of a built-in file. */ static Tcl_Channel Et_FileOpen ( Tcl_Interp *interp, /* The TCL interpreter doing the open */ char *zFilename, /* Name of the file to open */ char *modeString, /* Mode string for the open (ignored) */ int permissions /* Permissions for a newly created file (ignored) */ ) { char *zData; Et_FileStruct *p; int nData; char zName[50]; Tcl_Channel chan; static int count = 1; zData = FindBuiltinFile (zFilename, 1, &nData); if (zData == 0) return NULL; p = (Et_FileStruct *) Tcl_Alloc (sizeof (Et_FileStruct)); if (p == 0) return NULL; p->zData = zData; p->nData = nData; p->cursor = 0; sprintf (zName, "etbi_%x_%x", ((int) Et_FileOpen) >> 12, count++); chan = Tcl_CreateChannel (&builtinChannelType, zName, (ClientData) p, TCL_READABLE); return chan; } /* ** This routine does a stat() system call for a built-in file. */ static int Et_FileStat (char *path, struct stat *buf) { char *zData; int nData; zData = FindBuiltinFile (path, 0, &nData); if (zData == 0) { return -1; } memset (buf, 0, sizeof (*buf)); buf->st_mode = 0400; buf->st_size = nData; return 0; } /* ** This routien does an access() system call for a built-in file. */ static int Et_FileAccess (char *path, int mode) { char *zData; if (mode & 3) { return -1; } zData = FindBuiltinFile (path, 0, 0); if (zData == 0) { return -1; } return 0; } #endif /* ET_HAVE_INSERTPROC */ /* ** An overloaded version of "source". First check for the file ** is one of the built-ins. If it isn't a built-in, then check the ** disk. But if ET_STANDALONE is set (which corresponds to the ** "Strict" option in the user interface) then never check the disk. ** This gives us a quick way to check for the common error of ** sourcing a file that exists on the development by mistake, ** and only discovering the mistake when you move the program ** to your customer's machine. */ static int Et_Source (ET_TCLARGS) { char *z; if (argc != 2) { Et_ResultF (interp, "wrong # args: should be \"%s FILENAME\"", argv[0]); return TCL_ERROR; } z = FindBuiltinFile (argv[1], 1, 0); if (z) { int rc; rc = Tcl_Eval (interp, z); if (rc == TCL_ERROR) { char msg[200]; sprintf ( msg, "\n (file \"%.150s\" line %d)", argv[1], interp->errorLine); Tcl_AddErrorInfo (interp, msg); } else { rc = TCL_OK; } return rc; } #if ET_STANDALONE Et_ResultF (interp, "no such file: \"%s\"", argv[1]); return TCL_ERROR; #else return Tcl_EvalFile (interp, argv[1]); #endif } #ifndef ET_HAVE_INSERTPROC /* ** An overloaded version of "file exists". First check for the file ** in the file table, then go to disk. ** ** We only overload "file exists" if we don't have InsertProc() ** procedures. If we do have InsertProc() procedures, they will ** handle this more efficiently. */ static int Et_FileExists (ET_TCLARGS) { int i, rc; Tcl_DString str; if (argc == 3 && strncmp (argv[1], "exis", 4) == 0) { if (FindBuiltinFile (argv[2], 0, 0) != 0) { interp->result = "1"; return TCL_OK; } } Tcl_DStringInit (&str); Tcl_DStringAppendElement (&str, "Et_FileCmd"); for (i = 1; i < argc; i++) { Tcl_DStringAppendElement (&str, argv[i]); } rc = Tcl_Eval (interp, Tcl_DStringValue (&str)); Tcl_DStringFree (&str); return rc; } #endif /* ** This is the main Tcl interpreter. It's a global variable so it ** can be accessed easily from C code. */ Tcl_Interp *Et_Interp = 0; #if ET_WIN32 /* ** Implement the Et_MessageBox command on Windows platforms. We ** use the MessageBox() function from the Win32 API so that the ** error message will be displayed as a dialog box. Writing to ** standard error doesn't do anything on windows. */ int Et_MessageBox (ET_TCLARGS) { char *zMsg = "(Empty Message)"; char *zTitle = "Message..."; if (argc > 1) { zTitle = argv[1]; } if (argc > 2) { zMsg = argv[2]; } MessageBox (0, zMsg, zTitle, MB_ICONSTOP | MB_OK); return TCL_OK; } #endif /* ** A default implementation for "bgerror" */ static char zBgerror[] = "proc Et_Bgerror err {\n" " global errorInfo tk_library\n" " if {[info exists errorInfo]} {\n" " set ei $errorInfo\n" " } else {\n" " set ei {}\n" " }\n" " if {[catch {bgerror $err}]==0} return\n" " if {[string length $ei]>0} {\n" " set err $ei\n" " }\n" " if {[catch {Et_MessageBox {Error} $err}]} {\n" " puts stderr $err\n" " }\n" " exit\n" "}\n"; /* ** Do the initialization. ** ** This routine is called after the interpreter is created, but ** before Et_PreInit() or Et_AppInit() have been run. */ static int Et_DoInit (Tcl_Interp *interp) { int i; extern int Et_PreInit (Tcl_Interp *); extern int Et_AppInit (Tcl_Interp *); /* Insert our alternative stat(), access() and open() procedures ** so that any attempt to work with a file will check our built-in ** scripts first. */ #ifdef ET_HAVE_INSERTPROC TclStatInsertProc (Et_FileStat); TclAccessInsertProc (Et_FileAccess); TclOpenFileChannelInsertProc (Et_FileOpen); #endif /* Initialize the hash-table for built-in scripts */ FilenameHashInit (); /* The Et_NewBuiltFile command is inserted for use by FreeWrap ** and similar tools. */ #if ET_HAVE_OBJ Tcl_CreateObjCommand (interp, "Et_NewBuiltinFile", Et_NewBuiltinFileCmd, 0, 0); #else Tcl_CreateCommand (interp, "Et_NewBuiltinFile", Et_NewBuiltinFileCmd, 0, 0); #endif /* Overload the "file" and "source" commands */ #ifndef ET_HAVE_INSERTPROC { static char zRename[] = "rename file Et_FileCmd"; Tcl_Eval (interp, zRename); Tcl_CreateCommand (interp, "file", Et_FileExists, 0, 0); } #endif Tcl_CreateCommand (interp, "source", Et_Source, 0, 0); Et_Interp = interp; #ifdef ET_TCL_LIBRARY Tcl_SetVar (interp, "tcl_library", ET_TCL_LIBRARY, TCL_GLOBAL_ONLY); Tcl_SetVar (interp, "tcl_libPath", ET_TCL_LIBRARY, TCL_GLOBAL_ONLY); Tcl_SetVar2 (interp, "env", "TCL_LIBRARY", ET_TCL_LIBRARY, TCL_GLOBAL_ONLY); #endif #ifdef ET_TK_LIBRARY Tcl_SetVar (interp, "tk_library", ET_TK_LIBRARY, TCL_GLOBAL_ONLY); Tcl_SetVar2 (interp, "env", "TK_LIBRARY", ET_TK_LIBRARY, TCL_GLOBAL_ONLY); #endif #if ET_WIN32 Tcl_CreateCommand (interp, "Et_MessageBox", Et_MessageBox, 0, 0); #endif Tcl_Eval (interp, zBgerror); #if ET_HAVE_PREINIT if (Et_PreInit (interp) == TCL_ERROR) { goto initerr; } #endif if (Tcl_Init (interp) == TCL_ERROR) { goto initerr; } Et_GlobalEvalF (interp, "set dir $tcl_library;source $dir/tclIndex;unset dir"); #if ET_ENABLE_TK if (Tk_Init (interp) == TCL_ERROR) { goto initerr; } Tcl_StaticPackage (interp, "Tk", Tk_Init, 0); Et_GlobalEvalF (interp, "set dir $tk_library;source $dir/tclIndex;unset dir"); #endif /* Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY); */ for (i = 0; i < sizeof (Et_CmdSet) / sizeof (Et_CmdSet[0]) - 1; i++) { Tcl_CreateCommand (interp, Et_CmdSet[i].zName, Et_CmdSet[i].xProc, 0, 0); } #if ET_ENABLE_OBJ for (i = 0; i < sizeof (Et_ObjSet) / sizeof (Et_ObjSet[0]) - 1; i++) { Tcl_CreateObjCommand (interp, Et_ObjSet[i].zName, Et_ObjSet[i].xProc, 0, 0); } #endif Tcl_LinkVar (interp, "Et_EvalTrace", (char *) &Et_EvalTrace, TCL_LINK_BOOLEAN); Tcl_SetVar (interp, "et_version", ET_VERSION, TCL_GLOBAL_ONLY); #if ET_HAVE_APPINIT if (Et_AppInit (interp) == TCL_ERROR) { goto initerr; } #endif #if ET_ENABLE_TK && !ET_EXTENSION Et_NewBuiltinFile ("builtin:/console.tcl", zEtConsole, sizeof (zEtConsole)); #if ET_CONSOLE Tcl_Eval ( interp, "source builtin:/console.tcl\n" "console:create {.@console} {% } {Tcl/Tk Console}\n"); #endif #endif #ifdef ET_MAIN_SCRIPT if (Et_EvalF (interp, "source \"%q\"", ET_MAIN_SCRIPT) != TCL_OK) { goto initerr; } #endif return TCL_OK; initerr: Et_EvalF (interp, "Et_Bgerror \"%q\"", interp->result); return TCL_ERROR; } #if ET_READ_STDIN == 0 || ET_AUTO_FORK != 0 /* ** Initialize everything. */ static int Et_Local_Init (int argc, char **argv) { Tcl_Interp *interp; char *args; char buf[100]; #if !ET_HAVE_CUSTOM_MAINLOOP static char zWaitForever[] = #if ET_ENABLE_TK "bind . {if {![winfo exists .]} exit}\n" #endif "while 1 {vwait forever}"; #endif Tcl_FindExecutable (argv[0]); interp = Tcl_CreateInterp (); args = Tcl_Merge (argc - 1, argv + 1); Tcl_SetVar (interp, "argv", args, TCL_GLOBAL_ONLY); ckfree (args); sprintf (buf, "%d", argc - 1); Tcl_SetVar (interp, "argc", buf, TCL_GLOBAL_ONLY); Tcl_SetVar (interp, "argv0", argv[0], TCL_GLOBAL_ONLY); Tcl_SetVar (interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); Et_DoInit (interp); #if ET_HAVE_CUSTOM_MAINLOOP Et_CustomMainLoop (interp); #else Tcl_Eval (interp, zWaitForever); #endif return 0; } #endif /* ** This routine is called to do the complete initialization. */ int Et_Init (int argc, char **argv) { #ifdef ET_TCL_LIBRARY putenv ("TCL_LIBRARY=" ET_TCL_LIBRARY); #endif #ifdef ET_TK_LIBRARY putenv ("TK_LIBRARY=" ET_TK_LIBRARY); #endif #if ET_CONSOLE || !ET_READ_STDIN Et_Local_Init (argc, argv); #else #if ET_ENABLE_TK Tk_Main (argc, argv, Et_DoInit); #else Tcl_Main (argc, argv, Et_DoInit); #endif #endif return 0; } #if !ET_HAVE_MAIN && !ET_EXTENSION /* ** Main routine for UNIX programs. If the user has supplied ** their own main() routine in a C module, then the ET_HAVE_MAIN ** macro will be set to 1 and this code will be skipped. */ int main (int argc, char **argv) { #if ET_AUTO_FORK int rc = fork (); if (rc < 0) { perror ("can't fork"); exit (1); } if (rc > 0) return 0; close (0); open ("/dev/null", O_RDONLY); close (1); open ("/dev/null", O_WRONLY); #endif return Et_Init (argc, argv) != TCL_OK; } #endif #if ET_EXTENSION /* ** If the -extension flag is used, then generate code that will be ** turned into a loadable shared library or DLL, not a standalone ** executable. */ int ET_EXTENSION_NAME (Tcl_Interp *interp) { int i; #ifndef ET_HAVE_INSERTPROC Tcl_AppendResult ( interp, "mktclapp can only generate extensions for Tcl/Tk version " "8.0.3 and later. This is version " TCL_MAJOR_VERSION "." TCL_MINOR_VERSION "." TCL_RELEASE_SERIAL, 0); return TCL_ERROR; #endif #ifdef ET_HAVE_INSERTPROC #ifdef USE_TCL_STUBS if (Tcl_InitStubs (interp, "8.0", 0) == 0) { return TCL_ERROR; } if (Tk_InitStubs (interp, "8.0", 0) == 0) { return TCL_ERROR; } #endif Et_Interp = interp; TclStatInsertProc (Et_FileStat); TclAccessInsertProc (Et_FileAccess); TclOpenFileChannelInsertProc (Et_FileOpen); FilenameHashInit (); for (i = 0; i < sizeof (Et_CmdSet) / sizeof (Et_CmdSet[0]) - 1; i++) { Tcl_CreateCommand (interp, Et_CmdSet[i].zName, Et_CmdSet[i].xProc, 0, 0); } #if ET_ENABLE_OBJ for (i = 0; i < sizeof (Et_ObjSet) / sizeof (Et_ObjSet[0]) - 1; i++) { Tcl_CreateObjCommand (interp, Et_ObjSet[i].zName, Et_ObjSet[i].xProc, 0, 0); } #endif Tcl_LinkVar (interp, "Et_EvalTrace", (char *) &Et_EvalTrace, TCL_LINK_BOOLEAN); Tcl_SetVar (interp, "et_version", ET_VERSION, TCL_GLOBAL_ONLY); #if ET_HAVE_APPINIT if (Et_AppInit (interp) == TCL_ERROR) { return TCL_ERROR; } #endif #ifdef ET_MAIN_SCRIPT if (Et_EvalF (interp, "source \"%q\"", ET_MAIN_SCRIPT) != TCL_OK) { return TCL_ERROR; } #endif return TCL_OK; #endif /* ET_HAVE_INSERTPROC */ } int ET_SAFE_EXTENSION_NAME (Tcl_Interp *interp) { return ET_EXTENSION_NAME (interp); } #endif