/* 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; idxtype; } 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 && precision3 || (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+precision0 || 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=0 && precisionetBUFSIZE ){ 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 && precision0 ){ 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; izName); 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; i1 ){ 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; iresult); 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