WWW/ 40775 7006 0 0 5736767672 10007 5ustar joesystemWWW/TkWWW/ 40775 7006 0 0 5736770236 10760 5ustar joesystemWWW/TkWWW/Server/ 40775 7006 0 0 5736767611 12231 5ustar joesystemWWW/TkWWW/Server/HTAlert.c100664 7006 0 5677 5722521431 13773 0ustar joesystem/* Displaying messages and getting input for LineMode Browser ** ========================================================== ** ** REPLACE THIS MODULE with a GUI version in a GUI environment! ** ** History: ** Jun 92 Created May 1992 By C.T. Barker ** Feb 93 Simplified, portablised TBL ** Sep 93 Corrected 3 bugs in HTConfirm() :-( AL */ #include "HTAlert.h" #include "HTextDef.h" #include "TkWWWCmds.h" #include "tcp.h" /* for TOUPPER */ #include /* for toupper - should be in tcp.h */ PUBLIC void HTAlert ARGS1(CONST char *, Msg) { Tcl_VarEval(HtTclInterp, "tkW3HtAlert {", Msg , "}", NULL); } PUBLIC void HTProgress ARGS1(CONST char *, Msg) { Tcl_VarEval(HtTclInterp, "tkW3HtProgress {", Msg, "}", NULL); } PUBLIC BOOL HTConfirm ARGS1(CONST char *, Msg) { char Reply[4]; /* One more for terminating NULL -- AL */ char *URep; fprintf(stderr, "WWW: %s (y/n) ", Msg); /* (y/n) came twice -- AL */ if (!fgets(Reply, 4, stdin)) /* get reply, max 3 characters */ return NO; URep=Reply; while (*URep) { if (*URep == '\n') { *URep = (char)0; /* Overwrite newline */ break; } *URep=TOUPPER(*URep); URep++; /* This was previously embedded in the TOUPPER */ /* call an it became evaluated twice because */ /* TOUPPER is a macro -- AL */ } if ((strcmp(Reply,"YES")==0) || (strcmp(Reply,"Y")==0)) return(YES); else return(NO); } /* Prompt for answer and get text back */ PUBLIC char * HTPrompt ARGS2(CONST char *, Msg, CONST char *, deflt) { char Tmp[200]; char * rep = 0; fprintf(stderr, "WWW: %s", Msg); if (deflt) fprintf(stderr, " (RETURN for [%s]) ", deflt); if (!fgets(Tmp, 200, stdin)) return NULL; /* NULL string on error, Henrik */ Tmp[strlen(Tmp)-1] = (char)0; /* Overwrite newline */ StrAllocCopy(rep, *Tmp ? Tmp : deflt); return rep; } /* Prompt for password without echoing the reply */ PUBLIC char * HTPromptPassword ARGS1(CONST char *, Msg) { char *result = NULL; char *pw = (char*)getpass(Msg ? Msg : "Password: "); StrAllocCopy(result, pw); return result; } /* Prompt both username and password HTPromptUsernameAndPassword() ** --------------------------------- ** On entry, ** Msg is the prompting message. ** *username and ** *password are char pointers; they are changed ** to point to result strings. ** ** If *username is not NULL, it is taken ** to point to a default value. ** Initial value of *password is ** completely discarded. ** ** On exit, ** *username and *password point to newly allocated ** strings -- original strings pointed to by them ** are NOT freed. ** */ PUBLIC void HTPromptUsernameAndPassword ARGS3(CONST char *, Msg, char **, username, char **, password) { if (Msg) fprintf(stderr, "WWW: %s\n", Msg); *username = HTPrompt("Username: ", *username); *password = HTPromptPassword("Password: "); } WWW/TkWWW/Server/HTEvent.c100664 7006 0 6551 5722522400 13772 0ustar joesystem/* HTEvent.c ** MULTITHREADED ACCESS MANAGER ** ** (c) COPYRIGHT CERN 1994. ** Please first read the full copyright statement in the file COPYRIGH. ** ** Authors: ** HFN Henrik Frystyk Nielsen ** ** History: ** 05 Jul 95 Written from scratch ** ** Bugs ** */ /* Implementation dependent include files */ #include "tcp.h" /* Library include files */ #include "HTUtils.h" #include "HTAccess.h" #include "HTError.h" #include "HTThread.h" #include "HTList.h" #include "HTEvent.h" /* Implemented here */ #include "tk.h" PRIVATE HTList *UserList = NULL; /* List of call back functions */ PRIVATE fd_set HTfd_user; /* Bit array of sockets from user */ /* Type definitions and global variables etc. local to this module */ /* HTEventRegister ** ** Registers a socket as active for READ together with a callback ** function to call when select returns that the socket is pending. */ PRIVATE void HTEventProcessTkEvent(ClientData user_fd, int mask) { HTEventState state; HTRequest *cur_request = NULL; int status = 0; HTEventCallBack *pres = (HTEventCallBack *) user_fd; state = (*(pres->callback))(&cur_request); } PUBLIC BOOL HTEventRegister ARGS1(HTEventCallBack *, user_fd) { static BOOL done=NO; if (!user_fd) { if (THD_TRACE) fprintf(stderr, "EventRegist. Bad argument\n"); return NO; } if (!done) { FD_ZERO(&HTfd_user); done = YES; } FD_SET(user_fd->sockfd, &HTfd_user); HTThreadState(user_fd->sockfd, THD_SET_INTR); Tk_CreateFileHandler(user_fd->sockfd, TK_READABLE, HTEventProcessTkEvent, (ClientData) user_fd); return YES; } /* HTEventCleanup ** ** Clears the list of registered user sockets and call back functions */ PUBLIC void HTEventCleanup NOARGS { } /* HTEventCheckState ** ** This function checks the return code from the client call back ** function HTEventHandler() and HTEventRequestTerminate(). ** ** Returns: ** YES If we stay in eventloop ** NO If we return to client application */ PRIVATE BOOL HTEventCheckState ARGS2(HTRequest *, request, HTEventState, ret) { switch (ret) { case EVENT_TERM: /* Ignore it here */ case EVENT_OK: break; case EVENT_INTR: { int sockfd; if (request && request->net_info && (sockfd = request->net_info->sockfd) >= 0) HTThreadState(sockfd, THD_SET_INTR); } break; case EVENT_INTR_ALL: HTThreadMarkIntrAll(&HTfd_user); break; case EVENT_QUIT: return NO; break; default: if (THD_TRACE) fprintf(stderr, "HTEventLoop. Invalid return code\n"); } return YES; } /* HTEventLoop ** ** This is the internal socket event loop that is executed when the ** client doesn't want to keep the event loop. The client can interrupt ** this loop by sending an event on on of the registered sock descriptors ** in HTThreadInit() in the HTThread.c module ** ** The input parameters are for the first load, i.e. the home page. ** The keywords can be NULL. The Home Anchor can easily be found using ** HTHomeAnchor(). ** ** Returns: ** HT_ERROR if can't get first document or error in select ** (only if it failed with no blocking) ** HT_OK On normal exit */ PUBLIC int HTEventLoop ARGS3(HTRequest *, homerequest, HTParentAnchor *, homeanchor, CONST char *, homekeywords) { return HT_ERROR; } WWW/TkWWW/Server/HTInit.c100664 7006 0 1352 5660270634 13620 0ustar joesystem/* Configuration-specific Initialialization HTInit.c ** ---------------------------------------- */ /* Define a basic set of suffixes and presentations ** ------------------------------------------------ */ /* Implements: */ #include "HTInit.h" PUBLIC void HTFormatInit NOARGS { } /* Define a basic set of suffixes ** ------------------------------ ** ** The LAST suffix for a type is that used for temporary files ** of that type. ** The quality is an apriori bias as to whether the file should be ** used. Not that different suffixes can be used to represent files ** which are of the same format but are originals or regenerated, ** with different values. */ #ifndef NO_INIT PUBLIC void HTFileInit NOARGS { } #endif /* !NO_INIT */ WWW/TkWWW/Server/HTML.c100664 7006 0 34743 5722521440 13250 0ustar joesystem/* Structured stream to Rich hypertext converter ** ============================================ ** ** This generates of a hypertext object. It converts from the ** structured stream interface fro HTMl events into the style- ** oriented iunterface of the HText.h interface. This module is ** only used in clients and shouldnot be linked into servers. ** ** Override this module if making a new GUI browser. ** */ #include "HTML.h" #include #include #include "HTAtom.h" #include "HTextDef.h" #include "HTAlert.h" #include "HTMLGen.h" #include "HTParse.h" #include "TkWWWCmds.h" PUBLIC HTStyleSheet *styleSheet = NULL; /* HTML Object ** ----------- */ struct _HTStructured { CONST HTStructuredClass * isa; HTParentAnchor * node_anchor; HText * text; HTStream* target; /* Output stream */ HTStreamClass targetClass; /* Output routines */ HTChunk title; /* Grow by 128 */ char * comment_start; /* for literate programming */ char * comment_end; CONST SGML_dtd* dtd; BOOL in_title; BOOL in_comment; BOOL in_word; /* Have just had a non-white char */ BOOL in_verbatim; BOOL in_string; BOOL error; }; struct _HTStream { CONST HTStreamClass * isa; /* .... */ }; static char * ISO_Latin1[] = { "\306", /* capital AE diphthong (ligature) */ "\301", /* capital A, acute accent */ "\302", /* capital A, circumflex accent */ "\300", /* capital A, grave accent */ "\305", /* capital A, ring */ "\303", /* capital A, tilde */ "\304", /* capital A, dieresis or umlaut mark */ "\307", /* capital C, cedilla */ "\320", /* capital Eth, Icelandic */ "\311", /* capital E, acute accent */ "\312", /* capital E, circumflex accent */ "\310", /* capital E, grave accent */ "\313", /* capital E, dieresis or umlaut mark */ "\315", /* capital I, acute accent */ "\316", /* capital I, circumflex accent */ "\314", /* capital I, grave accent */ "\317", /* capital I, dieresis or umlaut mark */ "\321", /* capital N, tilde */ "\323", /* capital O, acute accent */ "\324", /* capital O, circumflex accent */ "\322", /* capital O, grave accent */ "\330", /* capital O, slash */ "\325", /* capital O, tilde */ "\326", /* capital O, dieresis or umlaut mark */ "\336", /* capital THORN, Icelandic */ "\332", /* capital U, acute accent */ "\333", /* capital U, circumflex accent */ "\331", /* capital U, grave accent */ "\334", /* capital U, dieresis or umlaut mark */ "\335", /* capital Y, acute accent */ "\341", /* small a, acute accent */ "\342", /* small a, circumflex accent */ "\346", /* small ae diphthong (ligature) */ "\340", /* small a, grave accent */ "\046", /* ampersand */ "\345", /* small a, ring */ "\343", /* small a, tilde */ "\344", /* small a, dieresis or umlaut mark */ "\347", /* small c, cedilla */ "\351", /* small e, acute accent */ "\352", /* small e, circumflex accent */ "\350", /* small e, grave accent */ "\360", /* small eth, Icelandic */ "\353", /* small e, dieresis or umlaut mark */ "\076", /* greater than */ "\355", /* small i, acute accent */ "\356", /* small i, circumflex accent */ "\354", /* small i, grave accent */ "\357", /* small i, dieresis or umlaut mark */ "\074", /* less than */ "\361", /* small n, tilde */ "\363", /* small o, acute accent */ "\364", /* small o, circumflex accent */ "\362", /* small o, grave accent */ "\370", /* small o, slash */ "\365", /* small o, tilde */ "\366", /* small o, dieresis or umlaut mark */ "\337", /* small sharp s, German (sz ligature) */ "\376", /* small thorn, Icelandic */ "\372", /* small u, acute accent */ "\373", /* small u, circumflex accent */ "\371", /* small u, grave accent */ "\374", /* small u, dieresis or umlaut mark */ "\375", /* small y, acute accent */ "\377", /* small y, dieresis or umlaut mark */ }; /* Entity values -- for ISO Latin 1 local representation ** ** This MUST match exactly the table referred to in the DTD! */ /* Set character set ** ---------------- */ PRIVATE char** p_entity_values = ISO_Latin1; /* Pointer to translation */ PUBLIC void HTMLUseCharacterSet ARGS1(HTMLCharacterSet, i) { p_entity_values = ISO_Latin1; } /*_________________________________________________________________________ ** ** A C T I O N R O U T I N E S */ PRIVATE void begin_string ARGS1(HTStructured *, me) { if (!me->in_string) { HText_puts(me->text, "tkW3HtAdd \""); me->in_string = YES; } } PRIVATE void begin_command ARGS1(HTStructured *, me) { if (me->in_string) { HText_puts(me->text, "\"\n"); me->in_string = NO; } } /* Character handling ** ------------------ */ PRIVATE void HTML_put_character ARGS2(HTStructured *, me, char, c) { if (me->in_comment) return; if (me->in_verbatim) { begin_string(me); HText_appendCharacter(me->text, c); return; } if (me->in_title) { HTChunkPutc(&me->title, c); } if (isspace(c)) { if (me->in_word) { begin_string (me); HText_appendCharacter(me->text, ' '); me->in_word = NO; } } else { begin_string(me); HText_appendCharacter(me->text, c); me->in_word = YES; } } /* String handling ** --------------- ** ** This is written separately from put_character becuase the loop can ** in some cases be promoted to a higher function call level for speed. */ PRIVATE void HTML_put_string ARGS2(HTStructured *, me, CONST char*, s) { CONST char *p; begin_string(me); if (me->in_comment) return; if (me->in_verbatim) { begin_string(me); HText_appendText(me->text, s); return; } if (me->in_title) { HTChunkPuts(&me->title, s); } for(p=s; *p; p++) { if (isspace(*p)) { if (me->in_word) { begin_string(me); HText_appendCharacter(me->text, ' '); me->in_word = NO; } } else { begin_string(me); HText_appendCharacter(me->text, *p); me->in_word = YES; } } /* for */ } /* Buffer write ** ------------ */ PRIVATE void HTML_write ARGS3(HTStructured *, me, CONST char*, s, int, l) { CONST char* p; CONST char* e = s+l; for (p=s; stext, "tkW3HtStartElement "); HText_puts(me->text, me->dtd->tags[element_number].name); if(present) for (i=0; idtd->tags[element_number].number_of_attributes; i++) { if (present[i]) { HText_puts(me->text, " -"); HText_puts(me->text, me->dtd->tags[element_number].attributes[i].name); HText_puts(me->text, " \""); if (value[i]) HText_appendText(me->text, value[i]); HText_puts(me->text, "\""); } } HText_puts(me->text, "\n"); HText_executeTCL(me->text); switch (element_number) { case HTML_TITLE: me->in_title = YES; HTChunkClear(&me->title); break; case HTML_DT: case HTML_DD: case HTML_LI: case HTML_P: case HTML_BR: case HTML_HR: me->in_word = NO; break; case HTML_COMMENT: case HTML_LISTING: /* Litteral text */ case HTML_XMP: case HTML_PLAINTEXT: case HTML_PRE: case HTML_LIT: me->in_verbatim = YES; /* @@@@@@@ Assumes these do not nest */ break; } /* end switch */ } /* End Element ** ----------- ** */ PRIVATE void HTML_end_element ARGS2(HTStructured *, me, int , element_number) { begin_command(me); HText_puts(me->text, "tkW3HtEndElement "); HText_puts(me->text, me->dtd->tags[element_number].name); HText_puts(me->text, "\n"); HText_executeTCL(me->text); switch(element_number) { case HTML_TITLE: HTChunkTerminate(&me->title); HTAnchor_setTitle(me->node_anchor, me->title.data); me->in_title = NO; break; case HTML_COMMENT: case HTML_LISTING: /* Litteral text */ case HTML_XMP: case HTML_PLAINTEXT: case HTML_PRE: case HTML_LIT: me->in_verbatim = NO; /* @@@@@@@ Assumes these do not nest */ break; default: break; } /* switch */ } /* Expanding entities ** ------------------ */ /* (In fact, they all shrink!) */ PRIVATE void HTML_put_entity ARGS2(HTStructured *, me, int, entity_number) { begin_command(me); HText_puts(me->text, "tkW3HtAddEntity "); HText_puts(me->text, me->dtd->entity_names[entity_number]); HText_puts(me->text, "\n"); } /* Free an HTML object ** ------------------- ** ** If the document is empty, the text object will not yet exist. So we could in fact abandon creating the document and return an error code. In fact an empty document is an important type of document, so we don't. ** ** If non-interactive, everything is freed off. No: crashes -listrefs ** Otherwise, the interactive object is left. */ PUBLIC int HTML_free ARGS1(HTStructured *, me) { CONST char *title; if (me->comment_end) HTML_put_string(me,me->comment_end); begin_command(me); HText_puts(me->text, "tkW3HtEndDoc\n"); HText_endAppend(me->text); HText_executeTCL(me->text); if (me->target) (*me->targetClass._free)(me->target); free(me); return 0; } PRIVATE int HTML_abort ARGS2(HTStructured *, me, HTError, e) { if (me->target) { (*me->targetClass.abort)(me->target, e); } free(me); return 0; } /* P U B L I C */ /* Structured Object Class ** ----------------------- */ PUBLIC CONST HTStructuredClass HTMLPresentation = /* As opposed to print etc */ { "text/html", HTML_free, HTML_abort, HTML_put_character, HTML_put_string, HTML_write, HTML_start_element, HTML_end_element, HTML_put_entity }; /* New Structured Text object ** -------------------------- ** ** The strutcured stream can generate either presentation, ** or plain text, or HTML. */ PUBLIC HTStructured* HTML_new ARGS5( HTRequest *, request, void *, param, HTFormat, input_format, HTFormat, output_format, HTStream *, output_stream) { char *address; HTStructured * me; me = (HTStructured*) malloc(sizeof(*me)); if (me == NULL) outofmem(__FILE__, "HTML_new"); if (output_format != WWW_PLAINTEXT && output_format != WWW_PRESENT && output_format != HTAtom_for("text/x-c")) { HTStream * intermediate = HTStreamStack(WWW_HTML, output_format, output_stream, request, NO); if (intermediate) return HTMLGenerator(intermediate); fprintf(stderr, "** Internal error: can't parse HTML to %s\n", HTAtom_name(output_format)); exit (-99); } me->isa = &HTMLPresentation; me->dtd = &DTD; me->node_anchor = request->anchor; me->title.size = 0; me->title.growby = 128; me->title.allocated = 0; me->title.data = 0; me->comment_start = NULL; me->comment_end = NULL; me->target = output_stream; me->in_verbatim = NO; me->in_word = NO; me->in_comment = NO; me->in_title = NO; me->in_string = NO; if (output_stream) me->targetClass = *output_stream->isa; /* Copy pointers */ me->text = HText_new2(request->anchor, output_stream); me->text->interp = ((HTTkW3Context *)request->context)->interp; HText_puts(me->text, "tkW3HtBeginDoc\n"); HText_executeTCL(me->text); begin_command(me); HText_puts(me->text, "tkW3HtSetAddress \""); address = HTAnchor_address((HTAnchor *) me->node_anchor); HText_appendText(me->text, address); HText_puts(me->text, "\"\n"); free(address); return (HTStructured*) me; } /* HTConverter for HTML to plain text ** ---------------------------------- ** ** This will convert from HTML to presentation or plain text. */ PUBLIC HTStream* HTMLToPlain ARGS5( HTRequest *, request, void *, param, HTFormat, input_format, HTFormat, output_format, HTStream *, output_stream) { return SGML_new(&DTD, HTML_new( request, NULL, input_format, output_format, output_stream)); } /* HTConverter for HTML to C code ** ------------------------------ ** ** C copde is like plain text but all non-preformatted code ** is commented out. ** This will convert from HTML to presentation or plain text. */ PUBLIC HTStream* HTMLToC ARGS5( HTRequest *, request, void *, param, HTFormat, input_format, HTFormat, output_format, HTStream *, output_stream) { HTStructured * html; (*output_stream->isa->put_string)(output_stream, "/* "); /* Before even title */ html = HTML_new(request, NULL, input_format, output_format, output_stream); html->comment_start = "/* "; html->dtd = &DTD; html->comment_end = " */\n"; /* Must start in col 1 for cpp */ /* HTML_put_string(html,html->comment_start); */ return SGML_new(&DTD, html); } /* Presenter for HTML ** ------------------ ** ** This will convert from HTML to presentation or plain text. ** ** Override this if you have a windows version */ #ifndef GUI PUBLIC HTStream* HTMLPresent ARGS5( HTRequest *, request, void *, param, HTFormat, input_format, HTFormat, output_format, HTStream *, output_stream) { return SGML_new(&DTD, HTML_new( request, NULL, input_format, output_format, output_stream)); } #endif /* Record error message as a hypertext object ** ------------------------------------------ ** ** The error message should be marked as an error so that ** it can be reloaded later. ** This implementation just throws up an error message ** and leaves the document unloaded. ** A smarter implementation would load an error document, ** marking at such so that it is retried on reload. ** ** On entry, ** sink is a stream to the output device if any ** number is the HTTP error number ** message is the human readable message. ** ** On exit, ** returns a negative number to indicate lack of success in the load. */ PUBLIC int HTLoadError ARGS3( HTRequest *, req, int, number, CONST char *, message) { char *err = "Oh I screwed up!"; Tcl_SetResult(HtTclInterp, (char *) message, TCL_VOLATILE); if (req && req->output_stream) (*req->output_stream->isa->abort)(req->output_stream, err); return -number; } WWW/TkWWW/Server/HTThread.c100664 7006 0 13703 5722522405 14142 0ustar joesystem/* HTThread.c ** MULTIPLE THREAD SOCKET MANAGEMENT ** */ /* Implemention dependent include files */ #include "tcp.h" /* Library include files */ #include "HTUtils.h" #include "HTAccess.h" #include "HTError.h" #include "HTThread.h" /* Implemented here */ #include "HTEvent.h" #include "tk.h" /* Type definitions and global variables etc. local to this module */ PRIVATE fd_set HTfd_intr; /* All sockets currently interrupted */ PRIVATE fd_set HTfd_set; /* All sockets currently registered */ PRIVATE int HTMaxfdpl = 0; /* Max number of sockets + 1 */ PRIVATE HTList *HTThreads = NULL; /* List of the HTNetInfo structures */ /* ------------------------------------------------------------------------- */ /* HTThreadInit ** ** Initiates the thread socket registers. It is very important that ** this function is called. It is currently done inside HTAccess in the ** HTAccessInit function. */ PRIVATE void HTThreadProcessTkEvent(ClientData user_request, int mask) { int status = 0; HTEventState state; HTRequest *cur_request = (HTRequest *) user_request; HTMethod method = cur_request->method; HTProtocol *callback = (HTProtocol *) HTAnchor_protocol(cur_request->anchor); if (method == METHOD_GET || method == METHOD_HEAD) { status = (*callback->load)(cur_request); } else { if (THD_TRACE) fprintf(stderr, "HTEventLoop. Method not supported @@@\n"); } if (THD_TRACE) fprintf(stderr, "HTEventLoop. Load returns: %d\n", status); if (status != HT_WOULD_BLOCK) { HTLoadTerminate(cur_request, status); if (THD_TRACE) fprintf(stderr,"HTEventLoop. Calling Terminate\n"); } } PUBLIC BOOL HTThreadInit NOARGS { static BOOL done=NO; if (done) { if (THD_TRACE) fprintf(stderr, "ThreadInit.. Already done\n"); return NO; } done = YES; /* Initialize the other internal bit arrays */ FD_ZERO(&HTfd_set); FD_ZERO(&HTfd_intr); return YES; } /* HTThreadGetFDInfo ** ** Returns the maximum bit width and the read and write bit array. */ PUBLIC int HTThreadGetFDInfo ARGS2(fd_set *, read, fd_set *, write) { return 0; } /* HTThreadState ** ** This function registers a socket as waiting for the action given ** (read or write etc.). */ PUBLIC void HTThreadState ARGS2(int, sockfd, HTThreadAction, action) { HTNetInfo *pres; int mask; if (THD_TRACE) { static char *actionmsg[] = { "SET WRITE", "CLEAR WRITE", "SET READ", "CLEAR READ", "SET INTERRUPT", "CLEAR INTERRUPT", "CLOSE" }; fprintf(stderr, "Thread...... Register socket number %d for action %s\n", sockfd, *(actionmsg+action)); } /* Find the corresponding HTNetInfo structure */ while ((pres = (HTNetInfo *) HTList_nextObject(HTThreads)) != NULL) if (pres->sockfd == sockfd) break; if (!pres) return; switch (action) { case THD_SET_WRITE: Tk_CreateFileHandler(sockfd, TK_WRITABLE, HTThreadProcessTkEvent, (ClientData) pres->request); FD_SET(sockfd, &HTfd_set); break; case THD_CLR_WRITE: Tk_DeleteFileHandler(sockfd); FD_CLR(sockfd, &HTfd_set); break; case THD_SET_READ: Tk_CreateFileHandler(sockfd, TK_READABLE, HTThreadProcessTkEvent, (ClientData) pres->request); FD_SET(sockfd, &HTfd_set); break; case THD_CLR_READ: Tk_DeleteFileHandler(sockfd); FD_CLR(sockfd, &HTfd_set); break; case THD_CLOSE: Tk_DeleteFileHandler(sockfd); FD_CLR(sockfd, &HTfd_intr); FD_CLR(sockfd, &HTfd_set); break; case THD_SET_INTR: Tk_DeleteFileHandler(sockfd); FD_SET(sockfd, &HTfd_intr); break; case THD_CLR_INTR: FD_CLR(sockfd, &HTfd_intr); break; default: if (THD_TRACE) fprintf(stderr, "Thread...... Illigal socket action\n"); } if (action == THD_CLOSE) { if (sockfd+1 >= HTMaxfdpl) { while (HTMaxfdpl > 0 && !FD_ISSET(HTMaxfdpl-1, &HTfd_set)) HTMaxfdpl--; } } else { if (sockfd+1 > HTMaxfdpl) HTMaxfdpl = sockfd+1; } if (THD_TRACE) fprintf(stderr, "Thread...... Max bitwidth is %d\n", HTMaxfdpl); } /* HTThreadIntr ** ** This function returns YES or NO to the question */ PUBLIC BOOL HTThreadIntr ARGS1(int, sockfd) { return FD_ISSET(sockfd, &HTfd_intr) ? YES : NO; } /* HTThreadMarkIntrAll ** ** Marks all Library sockets as interrupted. User sockets can not be ** interrupted */ PUBLIC void HTThreadMarkIntrAll ARGS1(CONST fd_set *, fd_user) { int cnt; if (THD_TRACE) fprintf(stderr, "Thread...... Mark ALL Library sockfd INTERRUPTED\n"); for (cnt=0; cnt #include #include #include "HTUtils.h" #include "HTString.h" #include "HTextDef.h" struct _HTStream { /* only know it as object */ CONST HTStreamClass * isa; /* ... */ }; /* Creation Method ** --------------- */ PUBLIC HText * HText_new ARGS1(HTParentAnchor *,anchor) { HText * self = (HText *) malloc(sizeof(*self)); if (!self) return self; self->node_anchor = anchor; self->output = HTChunkCreate(1024); self->execute_pointer = 0; self->error_code = TCL_OK; HTAnchor_setDocument(anchor, (HyperDoc *)self); return self; } /* Creation Method 2 ** --------------- ** ** Stream is assumed open and left open. */ PUBLIC HText * HText_new2 ARGS2( HTParentAnchor *, anchor, HTStream*, stream) { HText * this = HText_new(anchor); if (stream) { this->target = stream; this->targetClass = *stream->isa; /* copy action procedures */ } return this; } /* Free Entire Text ** ---------------- */ PUBLIC void HText_free ARGS1(HText *,self) { HTAnchor_setDocument(self->node_anchor, (HyperDoc *)0); HTChunkClear(self->output); } /* Object Building methods ** ----------------------- ** ** These are used by a parser to build the text in an object */ /* Append a character to the text object ** ------------------------------------- */ PUBLIC void HText_appendCharacter ARGS2(HText *,text, char,ch) { switch (ch) { case '{': /* add an escape before braces */ case '}': case '[': case ']': case '\"': case '\\': case '$': HText_putc(text, '\\'); break; } HText_putc(text, ch); } /* Anchor handling ** --------------- */ /* Start an anchor field */ PUBLIC void HText_beginAnchor ARGS2(HText *,text, HTChildAnchor *,anc) { HText_puts(text, "\"\n"); } PUBLIC void HText_endAnchor ARGS1(HText *,text) { HText_puts(text, "\"\n"); } PUBLIC void HText_appendText ARGS2(HText *,text, CONST char *,str) { CONST char * p; for(p=str; *p; p++) HText_appendCharacter(text, *p); } PUBLIC void HText_puts ARGS2(HText *,text, CONST char *, s) { HTChunkPuts(text->output, s); } PUBLIC void HText_putc ARGS2(HText *,text, CONST char, c) { HTChunkPutc(text->output, c); } PUBLIC void HText_executeTCL ARGS1(HText *,text) { if (text->error_code != TCL_OK) return; /* check there is enough in the buffer to execute */ if (text->output->size > 0) { int value; char *cmd_start; /* never access directly, it crash when chunk is just full use that instead : -- dl */ HTChunkPutc(text->output,0) ; /* subtract one from pointer so that the next write to the chunk overwrites the null at the end. WARNING: This breaks an abstraction barrier. Unfortunately, I don't know of a better way of doing this. Simply putting a NULL at the end of the string will cause problems if it is at the end of an allocated space. So I have to use HTChunkPutc(text->output,0); There should be a HTChunkRewind */ text->output->size--; /* This line needs to go after the HTChunkPutc command so that * It takes into account any memory reallocations performed in that * command */ cmd_start = text->output->data + text->execute_pointer; if (Tcl_CommandComplete(cmd_start)) { text->execute_pointer = text->output->size; value = Tcl_Eval(text->interp, cmd_start); if (value != TCL_OK) text->error_code = value; } } } PUBLIC void HText_endAppend ARGS1(HText *,text) { HTChunkTerminate(text->output); } /* Dump diagnostics to stderr */ PUBLIC void HText_dump ARGS1(HText *,text) { fprintf(stderr, "HText: Dump called\n"); } /* Return the anchor associated with this node */ PUBLIC HTParentAnchor * HText_nodeAnchor ARGS1(HText *,text) { return text->node_anchor; } /* Browsing functions ** ================== ** This procedure is called if a node is already loaded. In this case ** all we need to do is to execute the cache of TCL commands */ PUBLIC BOOL HText_select ARGS1(HText *,text) { if (Tcl_Eval(text->interp, text->output->data) == TCL_OK) return YES; else return NO; } PUBLIC BOOL HText_selectAnchor ARGS2(HText *,text, HTChildAnchor *,anchor) { return YES; } /* Editing functions - NOT IMPLEMENTED ** ================= ** ** These are called from the application. There are many more functions ** not included here from the orginal text object. */ /* Style handling: */ /* Apply this style to the selection */ PUBLIC void HText_applyStyle ARGS2(HText *, me, HTStyle *,style) { } /* Update all text with changed style. */ PUBLIC void HText_updateStyle ARGS2(HText *, me, HTStyle *,style) { } /* Return style of selection */ PUBLIC HTStyle * HText_selectionStyle ARGS2( HText *,me, HTStyleSheet *,sheet) { return 0; } /* Paste in styled text */ PUBLIC void HText_replaceSel ARGS3( HText *,me, CONST char *,aString, HTStyle *,aStyle) { } /* Apply this style to the selection and all similarly formatted text ** (style recovery only) */ PUBLIC void HTextApplyToSimilar ARGS2(HText *,me, HTStyle *,style) { } /* Select the first unstyled run. ** (style recovery only) */ PUBLIC void HTextSelectUnstyled ARGS2(HText *,me, HTStyleSheet *,sheet) { } /* Anchor handling: */ PUBLIC void HText_unlinkSelection ARGS1(HText *,me) { } PUBLIC HTAnchor * HText_referenceSelected ARGS1(HText *,me) { return 0; } PUBLIC HTAnchor * HText_linkSelTo ARGS2(HText *,me, HTAnchor *,anchor) { return 0; } PUBLIC void HText_setStyle ARGS2(HText *, me, HTStyle *, style) { } PUBLIC void HText_beginAppend ARGS1(HText *, text) { } WWW/TkWWW/Server/HTextDef.h100664 7006 0 1757 5722521451 14145 0ustar joesystem/* Specialities of GridText as subclass of HText ** ** This file has been modified for use with tkWWW */ #ifndef HTEXTDEF_H #define HTEXTDEF_H #include "HText.h" /* Superclass */ #include "HTChunk.h" #include "HTStream.h" #include "tcl.h" /* Notes on struct _Htext: ** next_line is valid iff state is false. ** top_of_screen line means the line at the top of the screen ** or just under the title if there is one. */ struct _HText { HTParentAnchor * node_anchor; HTChunk * output; int execute_pointer; HTStream* target; /* Output stream */ HTStreamClass targetClass; /* Output routines */ int error_code; Tcl_Interp *interp; }; #ifdef SHORT_NAMES #define HText_executeTCL HTTxEt #define HText_puts HTTxPs #define HText_putc HTTxPc #endif extern void HText_executeTCL PARAMS((HText *)); extern void HText_puts PARAMS((HText *, CONST char *)); extern void HText_putc PARAMS((HText *, CONST char)); #endif WWW/TkWWW/Server/Makefile.in100664 7006 0 4431 5722521455 14362 0ustar joesystem# Makefile for wwwish SHELL = /bin/sh #### Start of system configuration section. #### srcdir = @srcdir@ VPATH = @srcdir@ CC = @CC@ INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ CFLAGS = -O LDFLAGS = -O DEFINES = @DEFS@ prefix = /usr/local exec_prefix = $(prefix) # Where to install the executable. bindir = $(exec_prefix)/bin XINCLUDES = @XINCLUDES@ XLIBSW = @XLIBSW@ TCL_INCDIR = @TCL_INCDIR@ TK_INCDIR = @TK_INCDIR@ TCL_LIBDIR = @TCL_LIBDIR@ TK_LIBDIR = @TK_LIBDIR@ INCLUDES = -I$(srcdir) $(TCL_INCDIR) $(TK_INCDIR) \ $(XINCLUDES) -I$(srcdir)/../../Library/Implementation ALL_CFLAGS= $(DEFINES) $(INCLUDES) $(CFLAGS) WWW_LIB= ../Library/libwww.a LIBS= $(TCL_LIBDIR) $(TK_LIBDIR) -ltk -ltcl $(XLIBSW) @LIBS@ -lm TEST_LIBS=$(TCL_LIBDIR) -ltcl -lm objs = TkWWWCmds.o HText.o HTML.o HTAlert.o TkWWWBitmap.o HTEvent.o HTThread.o srcs = TkWWWCmds.c HText.c HTML.c HTAlert.c TkWWWBitmap.c HTEvent.c HTThread.c distfiles = $(srcs) all: libtkwww.a interp: @tk_www_tk_executable@ .c.o: $(CC) -c $(ALL_CFLAGS) $< @tk_www_tk_executable@: TclAppInit.o $(objs) $(CC) -o $@ $(LDFLAGS) TclAppInit.o $(objs) $(WWW_LIB) $(LIBS) wwwtest: TclAppTest.o $(objs) $(CC) -o $@ $(LDFLAGS) TclAppTest.o $(objs) $(WWW_LIB) $(TEST_LIBS) libtkwww.a: $(objs) ar r libtkwww.a $(objs) -ranlib libtkwww.a saber: TclAppTest.c $(srcs) saber $(LDFLAGS) TclAppTest.c $(srcs) $(TEST_LIBS) $(INCLUDES) Makefile: $(srcdir)/Makefile.in $(SHELL) config.status interpinstall: all $(INSTALL_PROGRAM) @tk_www_tk_executable@ $(bindir)/@tk_www_tk_executable@ install: TAGS: $(srcs) etags $(srcs) clean: rm -f sed *.o *.a core mostlyclean: clean distclean: clean rm -f Makefile config.status realclean: distclean rm -f TAGS dist: $(distfiles) echo sed-`sed -e '/version_string/!d' -e 's/[^0-9.]*\([0-9.]*\).*/\1/' -e q sed.c` > .fname rm -rf `cat .fname` mkdir `cat .fname` ln $(distfiles) `cat .fname` tar chZf `cat .fname`.tar.Z `cat .fname` rm -rf `cat .fname` .fname dist.afs: $(distfiles) echo sed-`sed -e '/version_string/!d' -e 's/[^0-9.]*\([0-9.]*\).*/\1/' -e q sed.c` > .fname rm -rf `cat .fname` mkdir `cat .fname` cd `cat .fname`; \ for file in $(distfiles); do ln -s ../"$$file" .; done; \ cd .. tar chf `cat .fname`.tar `cat .fname` gzip `cat .fname`.tar rm -rf `cat .fname` .fname WWW/TkWWW/Server/TclAppInit.c100664 7006 0 2421 5722521460 14461 0ustar joesystem#include #include #include #include /* * The following variable is a special hack that is needed in order for * Sun shared libraries to be used for Tcl. */ #ifdef NEED_MATHERR extern int matherr(); int *tclDummyMathPtr = (int *) matherr; #endif /* *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: * None: Tk_Main never returns here, so this procedure never * returns either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { Tk_Main(argc, argv); return 0; /* Needed only to prevent compiler warning. */ } int Tcl_AppInit(interp) Tcl_Interp *interp; { Tk_Window main; main = Tk_MainWindow(interp); if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (WWW_AppInit(interp) == TCL_ERROR) { return TCL_ERROR; } if (WWW_BitmapInit(interp) == TCL_ERROR) { return TCL_ERROR; } return (TCL_OK); } WWW/TkWWW/Server/TclAppTest.c100664 7006 0 371 5540463314 14460 0ustar joesystem#include #include int Tcl_AppInit(interp) Tcl_Interp *interp; { if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } if (WWW_AppInit(interp) == TCL_ERROR) { return TCL_ERROR; } return (TCL_OK); } WWW/TkWWW/Server/TkWWWBitmap.c100664 7006 0 20752 5660270657 14633 0ustar joesystem#include #define logo_width 90 #define logo_height 90 static char logo_bits[] = { 0x00, 0x00, 0x00, 0x00, 0xd8, 0xcf, 0x55, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0xff, 0x01, 0xc0, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xa0, 0x7f, 0x00, 0x2e, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xd8, 0x4f, 0x01, 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe7, 0xa0, 0x80, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x31, 0x00, 0xc4, 0xef, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x84, 0xef, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0x0c, 0xce, 0xff, 0x3f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x7c, 0x00, 0x00, 0x9f, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3e, 0x00, 0x00, 0xfd, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0xf4, 0xff, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0x80, 0x13, 0x00, 0x00, 0xf8, 0xff, 0xff, 0xff, 0x07, 0x00, 0x00, 0x00, 0xe0, 0x09, 0x00, 0x00, 0xf0, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x00, 0xfa, 0xed, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x38, 0x00, 0x7f, 0x80, 0x3f, 0x9c, 0xff, 0xff, 0x3f, 0x00, 0x00, 0x00, 0x08, 0x00, 0x08, 0x80, 0x5f, 0x62, 0xff, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x0c, 0x00, 0x08, 0x80, 0x1f, 0x40, 0xf6, 0xff, 0xff, 0x00, 0x00, 0x00, 0x02, 0x00, 0x08, 0x00, 0xaf, 0x36, 0xe8, 0xff, 0xff, 0x00, 0x00, 0x00, 0x03, 0x00, 0x08, 0x00, 0xfa, 0x0f, 0x14, 0xfd, 0xff, 0x01, 0x00, 0x00, 0x01, 0x00, 0x08, 0x00, 0xff, 0x0f, 0x00, 0xfc, 0xff, 0x03, 0x00, 0x80, 0x00, 0x00, 0x08, 0xc0, 0xff, 0x3f, 0x0c, 0xfc, 0xff, 0x07, 0x00, 0x40, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xfd, 0xff, 0xff, 0x07, 0x00, 0x40, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x20, 0x00, 0x00, 0x00, 0xf2, 0xff, 0xff, 0xff, 0xff, 0xf7, 0x0f, 0x00, 0x10, 0x00, 0x00, 0x00, 0xf8, 0xff, 0xff, 0xff, 0xf7, 0xef, 0x1f, 0x00, 0x30, 0x00, 0x10, 0x01, 0xfc, 0xff, 0xff, 0xff, 0xef, 0x9f, 0x1f, 0x00, 0x18, 0x00, 0x90, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xdf, 0xff, 0x38, 0x00, 0x18, 0x00, 0x50, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xbf, 0xff, 0x38, 0x00, 0x1c, 0x00, 0x30, 0x00, 0xff, 0xff, 0xff, 0xff, 0xbf, 0xff, 0x71, 0x00, 0x14, 0x00, 0x30, 0x00, 0xfe, 0xff, 0xff, 0xff, 0x7f, 0xff, 0x61, 0x00, 0x5a, 0x00, 0x50, 0x00, 0xfe, 0xff, 0xff, 0xff, 0x7f, 0xfe, 0x61, 0x00, 0x02, 0x00, 0x90, 0x01, 0xfe, 0xff, 0xff, 0xff, 0xff, 0xfc, 0xc0, 0x00, 0x41, 0x00, 0x10, 0x03, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7d, 0xc0, 0x00, 0x01, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x33, 0x80, 0x01, 0x03, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x27, 0x00, 0x01, 0x03, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x02, 0x0f, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f, 0x00, 0x02, 0x7f, 0x00, 0x00, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0xff, 0x03, 0x00, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0xff, 0x0f, 0x80, 0x20, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0xff, 0x0f, 0x80, 0x20, 0xc0, 0xff, 0xff, 0xff, 0xff, 0x1f, 0x00, 0x02, 0xff, 0x0f, 0x80, 0x24, 0x00, 0x00, 0xf8, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x1f, 0x80, 0x24, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x3f, 0x80, 0x2a, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x3f, 0x80, 0x2a, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x3f, 0x80, 0x2a, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x07, 0x00, 0x02, 0xff, 0xff, 0x01, 0x11, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x07, 0x00, 0x02, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x07, 0x00, 0x02, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x08, 0x02, 0xe0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x08, 0x02, 0xe0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x48, 0x02, 0xc0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x48, 0x02, 0xc0, 0xff, 0xff, 0x03, 0x00, 0x01, 0xff, 0xff, 0x07, 0x00, 0xa8, 0x02, 0xc0, 0xff, 0xff, 0x03, 0x00, 0x01, 0xff, 0xff, 0x03, 0x00, 0xa8, 0x02, 0x80, 0xff, 0xff, 0x41, 0x00, 0x01, 0xfa, 0xff, 0x01, 0x00, 0xa8, 0x02, 0xc0, 0xff, 0xff, 0x23, 0x00, 0x01, 0xfe, 0xff, 0x03, 0x00, 0x10, 0x01, 0xc0, 0xff, 0xff, 0x31, 0x80, 0x00, 0xf2, 0xff, 0x03, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x39, 0x80, 0x00, 0xf4, 0xff, 0x03, 0x00, 0x00, 0x00, 0xe0, 0xff, 0x7f, 0x3c, 0x80, 0x00, 0xe4, 0xff, 0x03, 0x00, 0x00, 0x00, 0xc0, 0xff, 0x3f, 0x1c, 0x40, 0x00, 0xe4, 0xff, 0x01, 0x00, 0x00, 0x00, 0xc0, 0xff, 0x1f, 0x0c, 0x40, 0x00, 0xe8, 0xff, 0x03, 0x00, 0x00, 0x00, 0x80, 0xff, 0x1f, 0x0e, 0x40, 0x00, 0xc8, 0xff, 0x00, 0x00, 0x40, 0x10, 0x80, 0xff, 0x1f, 0x06, 0x20, 0x00, 0xc8, 0x7f, 0x00, 0x00, 0x40, 0x10, 0x80, 0xff, 0x0f, 0x06, 0x20, 0x00, 0xd0, 0x7f, 0x00, 0x00, 0x40, 0x12, 0x80, 0xff, 0x07, 0x00, 0x10, 0x00, 0x90, 0x7f, 0x00, 0x00, 0x40, 0x12, 0x80, 0xff, 0x07, 0x00, 0x10, 0x00, 0xa0, 0x7f, 0x00, 0x00, 0x40, 0x15, 0x00, 0xff, 0x03, 0x00, 0x08, 0x00, 0x20, 0x7f, 0x00, 0x00, 0x40, 0x15, 0x00, 0xff, 0x01, 0x00, 0x08, 0x00, 0x40, 0x7e, 0x00, 0x00, 0x40, 0x15, 0x00, 0xff, 0x00, 0x00, 0x04, 0x00, 0x80, 0x7e, 0x00, 0x00, 0x80, 0x08, 0x00, 0x3e, 0x00, 0x00, 0x04, 0x00, 0x80, 0x7e, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x02, 0x00, 0x00, 0x7d, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x7a, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x34, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x78, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x40, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x60, 0x20, 0x00, 0x00, 0x00, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x09, 0x00, 0x00, 0x00, 0x00, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0x88, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0xa0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x03, 0xfe, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xdc, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xa0, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00}; #define balArrow_width 6 #define balArrow_height 6 static char balArrow_bits[] = { 0x1f, 0x07, 0x07, 0x09, 0x11, 0x20}; #define cbxarrow_width 11 #define cbxarrow_height 14 static char cbxarrow_bits[] = { 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0xfe, 0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00, 0xfe, 0x03, 0xfe, 0x03}; #define cross_width 14 #define cross_height 14 static char cross_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x06, 0x18, 0x0e, 0x1c, 0x1c, 0x0e, 0x38, 0x07, 0xf0, 0x03, 0xe0, 0x01, 0xe0, 0x01, 0xf0, 0x03, 0x38, 0x07, 0x1c, 0x0e, 0x0e, 0x1c, 0x06, 0x18}; #define decr_width 7 #define decr_height 4 static char decr_bits[] = { 0x7f, 0x3e, 0x1c, 0x08}; #define incr_width 7 #define incr_height 4 static char incr_bits[] = { 0x08, 0x1c, 0x3e, 0x7f}; #define tick_width 14 #define tick_height 14 static char tick_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x1c, 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc2, 0x01, 0xe7, 0x00, 0x7f, 0x00, 0x3e, 0x00, 0x1c, 0x00, 0x08, 0x00}; int WWW_BitmapInit(interp) Tcl_Interp *interp; { /* Create logo */ Tk_DefineBitmap(interp, Tk_GetUid("HtLogoBitmap"), logo_bits, logo_width, logo_height); Tk_DefineBitmap(interp, Tk_GetUid("balArrow"), balArrow_bits, balArrow_width, balArrow_height); Tk_DefineBitmap(interp, Tk_GetUid("cbxarrow"), cbxarrow_bits, cbxarrow_width, cbxarrow_height); Tk_DefineBitmap(interp, Tk_GetUid("cross"), cross_bits, cross_width, cross_height); Tk_DefineBitmap(interp, Tk_GetUid("decr"), decr_bits, decr_width, decr_height); Tk_DefineBitmap(interp, Tk_GetUid("incr"), incr_bits, incr_width, incr_height); Tk_DefineBitmap(interp, Tk_GetUid("tick"), tick_bits, tick_width, tick_height); return (TCL_OK); } WWW/TkWWW/Server/TkWWWBitmap.h100664 7006 0 171 5546756331 14572 0ustar joesystem#ifndef TKWWWBITMAP_H #define TKWWWBITMAP_H #include "tcl.h" extern int WWW_BitmapInit PARAMS((Tcl_Interp *)); #endif WWW/TkWWW/Server/TkWWWCmds.c100664 7006 0 20045 5722521465 14273 0ustar joesystem/* TkWWWCmds.c Adds World Wide Web commands to a Tcl interpreter ** =============== ** ** Authors: ** Joseph Wang, Department of Astronomy, University of Texas at Austin ** (joe@astro.as.utexas.edu) ** ** Copyright: ** Copyright (C) 1992-1994 ** Globewide Network Academy ** Macvicar Institute for Educational Software Development ** ** This program is free software; you can redistribute it and/or modify ** it under the terms of the GNU General Public License as published by ** the Free Software Foundation; either version 2 of the License, or ** (at your option) any later version. ** ** This program is distributed in the hope that it will be useful, ** but WITHOUT ANY WARRANTY; without even the implied warranty of ** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ** GNU General Public License for more details. ** ** You should have received a copy of the GNU General Public License ** along with this program; if not, write to the Free Software ** Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ /* Include c stuff ** --------------- */ #include #include #include #if STDC_HEADERS #include #include #endif /* Include World Wide Web stuff ** ---------------------------- */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* Some Global Variables ** --------------------- */ PUBLIC char * HTAppName = "tkWWW"; /* Application name */ PUBLIC char * HTAppVersion = SERVER_VERSION; /* Application version */ PUBLIC char * HTTkSaveDir = "/usr/tmp"; PUBLIC Tcl_Interp *HtTclInterp = NULL; EXTERN char * HTCacheDir; PRIVATE char cache_dir[256]; EXTERN HTPresentation* default_presentation; /* Macro to check arguments ** ------------------------ ** Assumes interpreter is in interp and number of arguments is in argc */ #define HtCheckArgc(min,max,function_name) \ if ((argc < (min)) || (argc > (max))) { \ Tcl_AppendResult(interp, (function_name), \ ": Incorrect number of arguments" , NULL); \ return (TCL_ERROR); \ } /* Procedures called by tkWWW functions ** ------------------------------------ */ PRIVATE int HtLoadCmd(dummy, interp, argc, argv) ClientData dummy; Tcl_Interp *interp; int argc; char **argv; { HTRequest *request; HTTkW3Context *context; int error_code; HtCheckArgc(2,3, "HtLoad"); request = HTRequest_new(); context = (HTTkW3Context *) malloc(sizeof(HTTkW3Context)); context->interp = interp; request->context = context; HtTclInterp = interp; context->error_code = TCL_OK; if (argc == 3) StrAllocCopy(context->target, argv[2]); else context->target = NULL; if (!HTLoadAbsolute(argv[1], request)) { if (*interp->result == '\0') { HTLoadError(request, 500, "Unable to access document."); } } context = request->context; if (context->target) { free(context->target); } error_code = context->error_code; free(context); HTRequest_delete (request); return (error_code); } PRIVATE int HtParseNameCmd(dummy, interp, argc, argv) ClientData dummy; Tcl_Interp *interp; int argc; char **argv; { char *current_address = NULL; HtCheckArgc(2,3,"HtParseName"); if (argc == 3 && argv[2] && *(argv[2])) StrAllocCopy(current_address, argv[2]); else current_address = HTFindRelatedName(); Tcl_SetResult(interp, HTParse(argv[1], current_address, PARSE_ALL), TCL_DYNAMIC); free(current_address); return (TCL_OK); } PRIVATE int HtUncacheCmd (dummy, interp, argc, argv) ClientData dummy; Tcl_Interp *interp; int argc; char **argv; { HTParentAnchor *parent_anchor; HTAnchor *anchor; HText *document; HtCheckArgc(2, 2, "HtUncache"); anchor = HTAnchor_findAddress(argv[1]); if (anchor) { parent_anchor = HTAnchor_parent(anchor); document = (HText *)HTAnchor_document(parent_anchor); if (document) HText_free(document); } return (TCL_OK); } PRIVATE int HtCleanupCmd(dummy, interp, argc, argv) ClientData dummy; Tcl_Interp *interp; int argc; char **argv; { HTLibTerminate(); return (TCL_OK); } PUBLIC BOOL HTTkSetOutputFile(request, fnam) HTRequest *request; CONST char *fnam; { char *address; HTTkW3Context *context = (HTTkW3Context *) request->context; HText *text = HText_new(request->anchor); HTChunkPuts(text->output, "tkW3ConfigDisplayFile "); if (context->target) HTChunkPuts(text->output, context->target); else HTChunkPuts(text->output, "{}"); HTChunkPuts(text->output, " "); HTChunkPuts(text->output, HTAtom_name(request->content_type)); HTChunkPuts(text->output, " "); HTChunkPuts(text->output, fnam); HTChunkPuts(text->output, " "); address = HTAnchor_address((HTAnchor *) request->anchor); HTChunkPuts(text->output, address); if (request->content_encoding) { HTChunkPuts(text->output, " "); HTChunkPuts(text->output, HTAtom_name(request->content_encoding)); } HTChunkPuts(text->output, "\n"); free(address); HTChunkTerminate(text->output); context->error_code = Tcl_Eval(context->interp, text->output->data); return 0; } PUBLIC HTStream* HTTkDisplay ARGS5( HTRequest *, request, void *, param, HTFormat, input_format, HTFormat, output_format, HTStream *, output_stream) { HTStream *me; char *old_cache; old_cache = HTCacheDir; HTCacheDir = HTTkSaveDir; request->callback = HTTkSetOutputFile; if (!request->content_type) { request->content_type = input_format; } me = HTSaveAndCallBack (request, param, input_format, output_format, output_stream); HTCacheDir = old_cache; return me; } PRIVATE int HtAddEncodingCmd(dummy, interp, argc, argv) ClientData dummy; Tcl_Interp *interp; int argc; char **argv; { float priority; HtCheckArgc(3, 4, "HtAddEncoding"); priority = (argc==3) ? 1.0 : atof(argv[3]); HTAddEncoding(argv[1], argv[2], priority); return (TCL_OK); } PRIVATE int HtAddTypeCmd(dummy, interp, argc, argv) ClientData dummy; Tcl_Interp *interp; int argc; char **argv; { float priority; HtCheckArgc(4, 5, "HtAddType"); priority = (argc==4) ? 1.0 : atof(argv[4]); HTAddType(argv[1], argv[2], argv[3], priority); return (TCL_OK); } /* Add tkWWW commands to a tcl interpreter init_tkWWW(interp) ** ------------- */ int WWW_AppInit(interp) Tcl_Interp *interp; { if (!HTConversions) HTConversions = HTList_new(); Tcl_CreateCommand(interp, "HtAddType", HtAddTypeCmd, (ClientData) NULL, (void (*)()) NULL); Tcl_CreateCommand(interp, "HtAddEncoding", HtAddEncodingCmd, (ClientData) NULL, (void (*)()) NULL); Tcl_CreateCommand(interp, "HtLoad", HtLoadCmd, (ClientData) NULL, (void (*)()) NULL); Tcl_CreateCommand(interp, "HtParseName", HtParseNameCmd, (ClientData) NULL, (void (*)()) NULL); Tcl_CreateCommand(interp, "HtUncache", HtUncacheCmd, (ClientData) NULL, (void (*)()) NULL); Tcl_CreateCommand(interp, "HtCleanup", HtCleanupCmd, (ClientData) NULL, (void (*)()) NULL); HTSetConversion(HTConversions, "www/mime", "*/*", HTMIMEConvert, 1.0, 0.0, 0.0); HTSetConversion(HTConversions, "text/html", "text/x-c", HTMLToC, 0.5, 0.0, 0.0); HTSetConversion(HTConversions, "text/html", "text/plain", HTMLToPlain, 0.5, 0.0, 0.0); HTSetConversion(HTConversions, "text/html", "www/present", HTMLPresent, 1.0, 0.0, 0.0); HTSetConversion(HTConversions, "text/plain", "text/html", HTPlainToHTML, 1.0, 0.0, 0.0); HTSetConversion(HTConversions, "*/*", "www/present", HTTkDisplay, 0.3, 0.0, 0.0); HTLibInit(); if (HTClientHost) HTSecure = YES; return (TCL_OK); } WWW/TkWWW/Server/TkWWWCmds.h100664 7006 0 447 5722521473 14243 0ustar joesystem#ifndef TKWWWCMDS_H #define TKWWWCMDS_H #include "HTAnchor.h" #include "HTFormat.h" #include "tcl.h" extern int WWW_AppInit PARAMS((Tcl_Interp *)); typedef struct _HTTkW3Context { Tcl_Interp *interp; int error_code; char *target; } HTTkW3Context; EXTERN Tcl_Interp *HtTclInterp; #endif WWW/TkWWW/Server/TkWWWTest.tcl100664 7006 0 10726 5722521476 14673 0ustar joesystem# tkWWW tk interface to World Wide Web # Copyright (C) 1992 Joseph Wang (joe@athena.mit.edu) # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ******* The Home Page set tkWWWHomePage http://uu-gna.mit.edu:8001/uu-gna/index.html proc tkW3HtSetName {address title} { } proc tkW3HtBeginDoc {} { } proc tkW3HtAdd {string {styles ""}} { } proc tkW3HtBegin {stack elem} { } proc tkW3HtEnd {stack elem} { } proc tkW3HtEndDoc {} { } proc tkW3HtSetNextId {id} { } proc tkW3HtAddBul {type} { } proc tkW3HtSetImg {source {ismap 0}} { } proc tkW3HtSetInd {href} { } proc tkW3HtSetBase {href} { } proc tkW3HtBlankLines {n} { } proc tkW3HtListPop {in_list} { upvar $in_list list set index [llength $list] incr index -1 set item [lindex $list $index] incr index -1 set list [lrange $list 0 $index] return $item } proc tkW3HtListLast {in_list} { upvar $in_list list set index [llength $list] incr index -1 lindex $list $index } proc tkW3HtButtonPress {w loc b tm} { global tkW3HtPage tkW3HtText set tag_list [.f.msg tag names $loc] set index [lsearch -regexp $tag_list {^i[0-9]+$}] if {$index == -1} { set index [lsearch -regexp $tag_list {^h[0-9]+$}] } if {$index != -1} { # undepress any depressed tag if {[string length $tkW3HtText(depressed)]} { $w tag configure $tkW3HtText(depressed) -relief raised set $tkW3HtText(depressed) {} $w tag raise sel update idletasks } set tkW3HtText(depressed) [lindex $tag_list $index] $w tag configure [lindex $tag_list $index] -relief sunken tkW3OutputSetMessage "" update idletasks } if {$b == 2} { set y [lindex [split $loc ,] 1] $w scan mark $y set tkW3HtText(b2time) $tm } } proc tkW3HtButtonRelease {w loc b tm} { global tkW3HtPage tkW3HtText set tag_list [.f.msg tag names $loc] # undepress any depressed tag if {[string length $tkW3HtText(depressed)]} { $w tag configure $tkW3HtText(depressed) -relief raised set $tkW3HtText(depressed) {} $w tag raise sel update idletasks } # Search for active tag # image tags override hypertext anchor tags set index [lsearch -regexp $tag_list {^i[0-9]+$}] if {$index == -1} { set index [lsearch -regexp $tag_list {^h[0-9]+$}] } if {$index != -1} { set tag [lindex $tag_list $index] $w tag configure $tag -relief raised update idletasks regexp {([hi])([0-9]+)} $tag {} tag_type i switch -- $tag_type { "i" { switch -- $b { "1" { tkW3NavigateRecordAndGoto \ $tkW3HtPage(image.$i) {} \ $tkW3HtPage(image.anchor.$i) \ $tkW3HtPage(image.ismap.$i) } "2" { tkW3NavigateClone $tkW3HtPage(image.$i) \ $tkW3HtPage(image.anchor.$i) \ $tkW3HtPage(image.ismap.$i) } "3" { tkW3EditChangeImage $i } } } "h" { switch -- $b { "1" { tkW3NavigateRecordAndGoto $tkW3HtPage(anchor.href.$i) } "2" { tkW3NavigateClone $tkW3HtPage(anchor.href.$i) } "3" { tkW3EditSetupAnchorDialog $w $i } } } } } else { if {$b == 2} { if {[expr $tm-$tkW3HtText(b2time)]<500} { if {![catch {selection get} s]} {tkW3EditInsert $w $s} } } } } proc tkW3HtProgress {msg} { tkW3OutputSetMessage $msg update idletasks } proc tkW3HtAlert {msg} { if {[regexp {404} $msg] && [regexp {file:[^ ]+} $msg page_name ]} { if {[DLG:msg "$msg Do you wish to create $page_name?" question "Yes" "No"]==1} { tkW3FileNewPage $page_name } { tkW3HistoryRestore } return } # Undo any changes we have made to the history list tkW3HistoryRestore # Tell the user about the error tkW3OutputError $msg } proc tkW3HtStartElement {tag args} { } proc tkW3HtEndElement {tag args} { } proc tkW3HtAddEntity {entity} { } proc tkW3HtHandleOptions {record arglist} { } WWW/TkWWW/Server/TkWWWVersion.h100664 7006 0 36 5575577674 15000 0ustar joesystem#define SERVER_VERSION "0.12" WWW/TkWWW/Server/logo.h100664 7006 0 15250 5546756341 13457 0ustar joesystem#define logo_width 90 #define logo_height 90 static char logo_bits[] = { 0x00, 0x00, 0x00, 0x00, 0xd8, 0xcf, 0x55, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0xff, 0x01, 0xc0, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xa0, 0x7f, 0x00, 0x2e, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xd8, 0x4f, 0x01, 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe7, 0xa0, 0x80, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x31, 0x00, 0xc4, 0xef, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x84, 0xef, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0x0c, 0xce, 0xff, 0x3f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x7c, 0x00, 0x00, 0x9f, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3e, 0x00, 0x00, 0xfd, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0xf4, 0xff, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0x80, 0x13, 0x00, 0x00, 0xf8, 0xff, 0xff, 0xff, 0x07, 0x00, 0x00, 0x00, 0xe0, 0x09, 0x00, 0x00, 0xf0, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x00, 0xfa, 0xed, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x38, 0x00, 0x7f, 0x80, 0x3f, 0x9c, 0xff, 0xff, 0x3f, 0x00, 0x00, 0x00, 0x08, 0x00, 0x08, 0x80, 0x5f, 0x62, 0xff, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x0c, 0x00, 0x08, 0x80, 0x1f, 0x40, 0xf6, 0xff, 0xff, 0x00, 0x00, 0x00, 0x02, 0x00, 0x08, 0x00, 0xaf, 0x36, 0xe8, 0xff, 0xff, 0x00, 0x00, 0x00, 0x03, 0x00, 0x08, 0x00, 0xfa, 0x0f, 0x14, 0xfd, 0xff, 0x01, 0x00, 0x00, 0x01, 0x00, 0x08, 0x00, 0xff, 0x0f, 0x00, 0xfc, 0xff, 0x03, 0x00, 0x80, 0x00, 0x00, 0x08, 0xc0, 0xff, 0x3f, 0x0c, 0xfc, 0xff, 0x07, 0x00, 0x40, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xfd, 0xff, 0xff, 0x07, 0x00, 0x40, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x20, 0x00, 0x00, 0x00, 0xf2, 0xff, 0xff, 0xff, 0xff, 0xf7, 0x0f, 0x00, 0x10, 0x00, 0x00, 0x00, 0xf8, 0xff, 0xff, 0xff, 0xf7, 0xef, 0x1f, 0x00, 0x30, 0x00, 0x10, 0x01, 0xfc, 0xff, 0xff, 0xff, 0xef, 0x9f, 0x1f, 0x00, 0x18, 0x00, 0x90, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xdf, 0xff, 0x38, 0x00, 0x18, 0x00, 0x50, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xbf, 0xff, 0x38, 0x00, 0x1c, 0x00, 0x30, 0x00, 0xff, 0xff, 0xff, 0xff, 0xbf, 0xff, 0x71, 0x00, 0x14, 0x00, 0x30, 0x00, 0xfe, 0xff, 0xff, 0xff, 0x7f, 0xff, 0x61, 0x00, 0x5a, 0x00, 0x50, 0x00, 0xfe, 0xff, 0xff, 0xff, 0x7f, 0xfe, 0x61, 0x00, 0x02, 0x00, 0x90, 0x01, 0xfe, 0xff, 0xff, 0xff, 0xff, 0xfc, 0xc0, 0x00, 0x41, 0x00, 0x10, 0x03, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7d, 0xc0, 0x00, 0x01, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x33, 0x80, 0x01, 0x03, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x27, 0x00, 0x01, 0x03, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x02, 0x0f, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f, 0x00, 0x02, 0x7f, 0x00, 0x00, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0xff, 0x03, 0x00, 0x00, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0xff, 0x0f, 0x80, 0x20, 0xfe, 0xff, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0xff, 0x0f, 0x80, 0x20, 0xc0, 0xff, 0xff, 0xff, 0xff, 0x1f, 0x00, 0x02, 0xff, 0x0f, 0x80, 0x24, 0x00, 0x00, 0xf8, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x1f, 0x80, 0x24, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x3f, 0x80, 0x2a, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x3f, 0x80, 0x2a, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x0f, 0x00, 0x02, 0xff, 0x3f, 0x80, 0x2a, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x07, 0x00, 0x02, 0xff, 0xff, 0x01, 0x11, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x07, 0x00, 0x02, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x07, 0x00, 0x02, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x08, 0x02, 0xe0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x08, 0x02, 0xe0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x48, 0x02, 0xc0, 0xff, 0xff, 0x03, 0x00, 0x02, 0xff, 0xff, 0x0f, 0x00, 0x48, 0x02, 0xc0, 0xff, 0xff, 0x03, 0x00, 0x01, 0xff, 0xff, 0x07, 0x00, 0xa8, 0x02, 0xc0, 0xff, 0xff, 0x03, 0x00, 0x01, 0xff, 0xff, 0x03, 0x00, 0xa8, 0x02, 0x80, 0xff, 0xff, 0x41, 0x00, 0x01, 0xfa, 0xff, 0x01, 0x00, 0xa8, 0x02, 0xc0, 0xff, 0xff, 0x23, 0x00, 0x01, 0xfe, 0xff, 0x03, 0x00, 0x10, 0x01, 0xc0, 0xff, 0xff, 0x31, 0x80, 0x00, 0xf2, 0xff, 0x03, 0x00, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x39, 0x80, 0x00, 0xf4, 0xff, 0x03, 0x00, 0x00, 0x00, 0xe0, 0xff, 0x7f, 0x3c, 0x80, 0x00, 0xe4, 0xff, 0x03, 0x00, 0x00, 0x00, 0xc0, 0xff, 0x3f, 0x1c, 0x40, 0x00, 0xe4, 0xff, 0x01, 0x00, 0x00, 0x00, 0xc0, 0xff, 0x1f, 0x0c, 0x40, 0x00, 0xe8, 0xff, 0x03, 0x00, 0x00, 0x00, 0x80, 0xff, 0x1f, 0x0e, 0x40, 0x00, 0xc8, 0xff, 0x00, 0x00, 0x40, 0x10, 0x80, 0xff, 0x1f, 0x06, 0x20, 0x00, 0xc8, 0x7f, 0x00, 0x00, 0x40, 0x10, 0x80, 0xff, 0x0f, 0x06, 0x20, 0x00, 0xd0, 0x7f, 0x00, 0x00, 0x40, 0x12, 0x80, 0xff, 0x07, 0x00, 0x10, 0x00, 0x90, 0x7f, 0x00, 0x00, 0x40, 0x12, 0x80, 0xff, 0x07, 0x00, 0x10, 0x00, 0xa0, 0x7f, 0x00, 0x00, 0x40, 0x15, 0x00, 0xff, 0x03, 0x00, 0x08, 0x00, 0x20, 0x7f, 0x00, 0x00, 0x40, 0x15, 0x00, 0xff, 0x01, 0x00, 0x08, 0x00, 0x40, 0x7e, 0x00, 0x00, 0x40, 0x15, 0x00, 0xff, 0x00, 0x00, 0x04, 0x00, 0x80, 0x7e, 0x00, 0x00, 0x80, 0x08, 0x00, 0x3e, 0x00, 0x00, 0x04, 0x00, 0x80, 0x7e, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x02, 0x00, 0x00, 0x7d, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x7a, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x34, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x78, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x40, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x08, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x60, 0x20, 0x00, 0x00, 0x00, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x09, 0x00, 0x00, 0x00, 0x00, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0x88, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0xa0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x03, 0xfe, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xdc, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xa0, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00}; WWW/TkWWW/Tcl/ 40775 7006 0 0 5736767656 11516 5ustar joesystemWWW/TkWWW/Tcl/library/ 40775 7006 0 0 5736767672 13160 5ustar joesystemWWW/TkWWW/Tcl/library/button.tcl100664 7006 0 11553 5722532025 15272 0ustar joesystem# button.tcl -- # # This file defines the default bindings for Tk label, button, # checkbutton, and radiobutton widgets. # # @(#) button.tcl 1.14 94/12/17 16:05:11 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkButtonBind -- # This procedure is invoked the first time the mouse enters a button, # checkbutton, or radiobutton, or any one of these widgets receives # the input focus. It creates all of the class bindings for the widgets. # # Arguments: # w - The widget that was just entered or just received # the input focus. # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. proc tkButtonBind {w {event {}}} { if {$event == "Enter"} { tkButtonEnter $w } # Standard Motif bindings: bind Button {} bind Button { tkButtonEnter %W } bind Button { tkButtonLeave %W } bind Button <1> { tkButtonDown %W } bind Button { tkButtonUp %W } bind Button { tkButtonInvoke %W } bind Checkbutton {} bind Checkbutton { tkButtonEnter %W } bind Checkbutton { tkButtonLeave %W } bind Checkbutton <1> { tkCheckRadioInvoke %W } bind Checkbutton { tkCheckRadioInvoke %W } bind Radiobutton {} bind Radiobutton { tkButtonEnter %W } bind Radiobutton { tkButtonLeave %W } bind Radiobutton <1> { tkCheckRadioInvoke %W } bind Radiobutton { tkCheckRadioInvoke %W } } # tkButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. # # Arguments: # w - The name of the widget. proc tkButtonEnter {w} { global tkPriv tk_strictMotif if {[$w cget -state] != "disabled"} { if {!$tk_strictMotif} { $w config -state active } if {$tkPriv(buttonWindow) == $w} { $w configure -state active -relief sunken } } set tkPriv(window) $w } # tkButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to # inactive. If we're leaving the button window with a mouse button # pressed (tkPriv(buttonWindow) == $w), restore the relief of the # button too. # # Arguments: # w - The name of the widget. proc tkButtonLeave w { global tkPriv tk_strictMotif if {[$w cget -state] != "disabled"} { $w config -state normal } if {$w == $tkPriv(buttonWindow)} { $w configure -relief $tkPriv(relief) } set tkPriv(window) "" } # tkButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes # the relief to sunken. # # Arguments: # w - The name of the widget. proc tkButtonDown w { global tkPriv tk_strictMotif set tkPriv(relief) [lindex [$w config -relief] 4] if {[$w cget -state] != "disabled"} { set tkPriv(buttonWindow) $w $w config -relief sunken -state active } } # tkButtonUp -- # The procedure below is invoked when the mouse button is released # in a button widget. It restores the button's relief and invokes # the command as long as the mouse hasn't left the button. # # Arguments: # w - The name of the widget. proc tkButtonUp w { global tkPriv tk_strictMotif if {$w == $tkPriv(buttonWindow)} { set tkPriv(buttonWindow) "" $w config -relief $tkPriv(relief) if $tk_strictMotif { $w configure -state normal } if {($w == $tkPriv(window)) && ([$w cget -state] != "disabled")} { uplevel #0 [list $w invoke] } } } # tkButtonInvoke -- # The procedure below is called when a button is invoked through # the keyboard. It simulate a press of the button via the mouse. # # Arguments: # w - The name of the widget. proc tkButtonInvoke w { if {[$w cget -state] != "disabled"} { set oldRelief [$w cget -relief] set oldState [$w cget -state] $w configure -state active -relief sunken update idletasks after 100 $w configure -state $oldState -relief $oldRelief uplevel #0 [list $w invoke] } } # tkCheckRadioInvoke -- # The procedure below is invoked when the mouse button is pressed in # a checkbutton or radiobutton widget, or when the widget is invoked # through the keyboard. It invokes the widget if it # isn't disabled. # # Arguments: # w - The name of the widget. proc tkCheckRadioInvoke w { if {[$w cget -state] != "disabled"} { uplevel #0 [list $w invoke] } } WWW/TkWWW/Tcl/library/dialog.tcl100664 7006 0 6361 5722532026 15200 0ustar joesystem# dialog.tcl -- # # This file defines the procedure tk_dialog, which creates a dialog # box containing a bitmap, a message, and one or more buttons. # # @(#) dialog.tcl 1.12 94/12/23 11:15:43 # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # # tk_dialog: # # This procedure displays a dialog box, waits for a button in the dialog # to be invoked, then returns the index of the selected button. # # Arguments: # w - Window to use for dialog top-level. # title - Title to display in dialog's decorative frame. # text - Message to display in dialog. # bitmap - Bitmap to display in dialog (empty string means none). # default - Index of button that is to display the default ring # (-1 means none). # args - One or more strings to display in buttons across the # bottom of the dialog box. proc tk_dialog {w title text bitmap default args} { global tkPriv # 1. Create the top-level window and divide it into top # and bottom parts. catch {destroy $w} toplevel $w -class Dialog wm title $w $title wm iconname $w Dialog wm protocol $w WM_DELETE_WINDOW { } wm transient $w [winfo toplevel [winfo parent $w]] frame $w.top -relief raised -bd 1 pack $w.top -side top -fill both frame $w.bot -relief raised -bd 1 pack $w.bot -side bottom -fill both # 2. Fill the top part with bitmap and message. label $w.msg -wraplength 3i -justify left -text $text \ -font -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m if {$bitmap != ""} { label $w.bitmap -bitmap $bitmap pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m } # 3. Create a row of buttons at the bottom of the dialog. set i 0 foreach but $args { button $w.button$i -text $but -command "set tkPriv(button) $i" if {$i == $default} { frame $w.default -relief sunken -bd 1 raise $w.button$i $w.default pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m pack $w.button$i -in $w.default -padx 2m -pady 2m bind $w "$w.button$i flash; set tkPriv(button) $i" } else { pack $w.button$i -in $w.bot -side left -expand 1 \ -padx 3m -pady 2m } incr i } # 4. Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display and de-iconify it. wm withdraw $w update idletasks set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - [winfo vrootx [winfo parent $w]]] set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - [winfo vrooty [winfo parent $w]]] wm geom $w +$x+$y wm deiconify $w # 5. Set a grab and claim the focus too. set oldFocus [focus] grab $w tkwait visibility $w if {$default >= 0} { focus $w.button$default } else { focus $w } # 6. Wait for the user to respond, then restore the focus and # return the index of the selected button. tkwait variable tkPriv(button) destroy $w focus $oldFocus return $tkPriv(button) } WWW/TkWWW/Tcl/library/entry.tcl100664 7006 0 26674 5722532027 15134 0ustar joesystem# entry.tcl -- # # This file defines the default bindings for Tk entry widgets. # # @(#) entry.tcl 1.23 95/01/08 16:10:00 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkEntryBind -- # This procedure is invoked the first time the mouse enters an # entry widget or an entry widget receives the input focus. It creates # all of the class bindings for entries. # # Arguments: # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. proc tkEntryBind event { global tk_strictMotif bind Entry {} bind Entry {} # Standard Motif bindings: bind Entry <1> { tkEntryButton1 %W %x %W select clear } bind Entry { tkEntryMouseSelect %W %x } bind Entry { set tkPriv(selectMode) word tkEntryMouseSelect %W %x catch {%W icursor sel.first} } bind Entry { set tkPriv(selectMode) line tkEntryMouseSelect %W %x %W icursor 0 } bind Entry { set tkPriv(selectMode) char %W select adjust @%x } bind Entry { set tkPriv(selectMode) word tkEntryMouseSelect %W %x } bind Entry { set tkPriv(selectMode) line tkEntryMouseSelect %W %x } bind Entry { tkEntryAutoScan %W %x } bind Entry { tkCancelRepeat } bind Entry { tkCancelRepeat } bind Entry { %W icursor @%x } bind Entry { tkEntrySetCursor %W [expr [%W index insert] - 1] } bind Entry { tkEntrySetCursor %W [expr [%W index insert] + 1] } bind Entry { tkEntryKeySelect %W [expr [%W index insert] - 1] tkEntrySeeInsert %W } bind Entry { tkEntryKeySelect %W [expr [%W index insert] + 1] tkEntrySeeInsert %W } bind Entry { tkEntrySetCursor %W \ [string wordstart [%W get] [expr [%W index insert] - 1]] } bind Entry { tkEntrySetCursor %W [string wordend [%W get] [%W index insert]] } bind Entry { tkEntryKeySelect %W \ [string wordstart [%W get] [expr [%W index insert] - 1]] tkEntrySeeInsert %W } bind Entry { tkEntryKeySelect %W [string wordend [%W get] [%W index insert]] tkEntrySeeInsert %W } bind Entry { tkEntrySetCursor %W 0 } bind Entry { tkEntryKeySelect %W 0 tkEntrySeeInsert %W } bind Entry { tkEntrySetCursor %W end } bind Entry { tkEntryKeySelect %W end tkEntrySeeInsert %W } bind Entry { if [%W selection present] { %W delete sel.first sel.last } else { %W delete insert } } bind Entry { tkEntryBackspace %W } bind Entry { %W select from insert } bind Entry { tkListboxBeginSelect %W [%W index active] } bind Listbox { tkListboxBeginExtend %W [%W index active] } bind Listbox { tkListboxBeginExtend %W [%W index active] } bind Listbox { tkListboxCancel %W } bind Listbox { tkListboxSelectAll %W } bind Listbox { if {[%W cget -selectmode] != "browse"} { %W select clear 0 end } } # Additional Tk bindings that aren't part of the Motif look and feel: bind Listbox <2> { %W scan mark %x %y } bind Listbox { %W scan dragto %x %y } rename tkListboxBind {} } # tkListboxBeginSelect -- # # This procedure is typically invoked on button-1 presses. It begins # the process of making a selection in the listbox. Its exact behavior # depends on the selection mode currently in effect for the listbox; # see the Motif documentation for details. # # Arguments: # w - The listbox widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. proc tkListboxBeginSelect {w el} { global tkPriv if {[$w cget -selectmode] == "multiple"} { if [$w selection includes $el] { $w selection clear $el } else { $w selection set $el } } else { $w selection clear 0 end $w selection set $el $w selection anchor $el set tkPriv(listboxSelection) {} set tkPriv(listboxPrev) $el } } # tkListboxMotion -- # # This procedure is called to process mouse motion events while # button 1 is down. It may move or extend the selection, depending # on the listbox's selection mode. # # Arguments: # w - The listbox widget. # el - The element under the pointer (must be a number). proc tkListboxMotion {w el} { global tkPriv if {$el == $tkPriv(listboxPrev)} { return } set anchor [$w index anchor] switch [$w cget -selectmode] { browse { $w selection clear 0 end $w selection set $el } extended { set i $tkPriv(listboxPrev) if [$w selection includes anchor] { $w selection clear $i $el $w selection set anchor $el } else { $w selection clear $i $el $w selection clear anchor $el } while {($i < $el) && ($i < $anchor)} { if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { $w selection set $i } incr i } while {($i > $el) && ($i > $anchor)} { if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { $w selection set $i } incr i -1 } set tkPriv(listboxPrev) $el } } } # tkListboxBeginExtend -- # # This procedure is typically invoked on shift-button-1 presses. It # begins the process of extending a selection in the listbox. Its # exact behavior depends on the selection mode currently in effect # for the listbox; see the Motif documentation for details. # # Arguments: # w - The listbox widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. proc tkListboxBeginExtend {w el} { if {([$w cget -selectmode] == "extended") && [$w selection includes anchor]} { tkListboxMotion $w $el } } # tkListboxBeginToggle -- # # This procedure is typically invoked on control-button-1 presses. It # begins the process of toggling a selection in the listbox. Its # exact behavior depends on the selection mode currently in effect # for the listbox; see the Motif documentation for details. # # Arguments: # w - The listbox widget. # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. proc tkListboxBeginToggle {w el} { global tkPriv if {[$w cget -selectmode] == "extended"} { set tkPriv(listboxSelection) [$w curselection] set tkPriv(listboxPrev) $el $w selection anchor $el if [$w selection includes $el] { $w selection clear $el } else { $w selection set $el } } } # tkListboxAutoScan -- # This procedure is invoked when the mouse leaves an entry window # with button 1 down. It scrolls the window up, down, left, or # right, depending on where the mouse left the window, and reschedules # itself as an "after" command so that the window continues to scroll until # the mouse moves back into the window or the mouse button is released. # # Arguments: # w - The entry window. # x - The x-coordinate of the mouse when it left the window. # y - The y-coordinate of the mouse when it left the window. proc tkListboxAutoScan {w x y} { global tkPriv if {$y >= [winfo height $w]} { $w yview scroll 1 units } elseif {$y < 0} { $w yview scroll -1 units } elseif {$x >= [winfo width $w]} { $w xview scroll 2 units } elseif {$x < 0} { $w xview scroll -2 units } else { return } tkListboxMotion $w [$w index @$x,$y] set tkPriv(afterId) [after 50 tkListboxAutoScan $w $x $y] } # tkListboxUpDown -- # # Moves the location cursor (active element) up or down by one element, # and changes the selection if we're in browse or extended selection # mode. # # Arguments: # w - The listbox widget. # amount - +1 to move down one item, -1 to move back one item. proc tkListboxUpDown {w amount} { global tkPriv $w activate [expr [$w index active] + $amount] $w see active switch [$w cget -selectmode] { browse { $w selection clear 0 end $w selection set active } extended { $w selection clear 0 end $w selection set active $w selection anchor active set tkPriv(listboxPrev) [$w index active] set tkPriv(listboxSelection) {} } } } # tkListboxExtendUpDown -- # # Does nothing unless we're in extended selection mode; in this # case it moves the location cursor (active element) up or down by # one element, and extends the selection to that point. # # Arguments: # w - The listbox widget. # amount - +1 to move down one item, -1 to move back one item. proc tkListboxExtendUpDown {w amount} { if {[$w cget -selectmode] != "extended"} { return } $w activate [expr [$w index active] + $amount] $w see active tkListboxMotion $w [$w index active] } # tkListboxDataExtend # # This procedure is called for key-presses such as Shift-KEndData. # If the selection mode isn't multiple or extend then it does nothing. # Otherwise it moves the active element to el and, if we're in # extended mode, extends the selection to that point. # # Arguments: # w - The listbox widget. # el - An integer element number. proc tkListboxDataExtend {w el} { set mode [$w cget -selectmode] if {$mode == "extended"} { $w activate $el $w see $el if [$w selection includes anchor] { tkListboxMotion $w $el } } elseif {$mode == "multiple"} { $w activate $el $w see $el } } # tkListboxCancel # # This procedure is invoked to cancel an extended selection in # progress. If there is an extended selection in progress, it # restores all of the items between the active one and the anchor # to their previous selection state. # # Arguments: # w - The listbox widget. proc tkListboxCancel w { global tkPriv if {[$w cget -selectmode] != "extended"} { return } set first [$w index anchor] set last $tkPriv(listboxPrev) if {$first > $last} { set tmp $first set first $last set last $tmp } $w selection clear $first $last while {$first <= $last} { if {[lsearch $tkPriv(listboxSelection) $first] >= 0} { $w selection set $first } incr first } } # tkListboxSelectAll # # This procedure is invoked to handle the "select all" operation. # For single and browse mode, it just selects the active element. # Otherwise it selects everything in the widget. # # Arguments: # w - The listbox widget. proc tkListboxSelectAll w { set mode [$w cget -selectmode] if {($mode == "single") || ($mode == "browse")} { $w selection clear 0 end $w selection set active } else { $w selection set 0 end } } WWW/TkWWW/Tcl/library/menu.tcl100664 7006 0 53131 5722532031 14716 0ustar joesystem# menu.tcl -- # # This file defines the default bindings for Tk menus and menubuttons. # It also implements keyboard traversal of menus and implements a few # other utility procedures related to menus. # # @(#) menu.tcl 1.34 94/12/19 17:09:09 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------- # Elements of tkPriv that are used in this file: # # cursor - Saves the -cursor option for the posted menubutton. # focus - Saves the focus during a menu selection operation. # Focus gets restored here when the menu is unposted. # inMenubutton - The name of the menubutton widget containing # the mouse, or an empty string if the mouse is # not over any menubutton. # popup - If a menu has been popped up via tk_popup, this # gives the name of the menu. Otherwise this # value is empty. # postedMb - Name of the menubutton whose menu is currently # posted, or an empty string if nothing is posted # A grab is set on this widget. # relief - Used to save the original relief of the current # menubutton. # window - When the mouse is over a menu, this holds the # name of the menu; it's cleared when the mouse # leaves the menu. #------------------------------------------------------------------------- #------------------------------------------------------------------------- # Overall note: # This file is tricky because there are four different ways that menus # can be used: # # 1. As a pulldown from a menubutton. This is the most common usage. # In this style, the variable tkPriv(postedMb) identifies the posted # menubutton. # 2. As a torn-off menu copied from some other menu. In this style # tkPriv(postedMb) is empty, and the top-level menu is no # override-redirect. # 3. As an option menu, triggered from an option menubutton. In thi # style tkPriv(postedMb) identifies the posted menubutton. # 4. As a popup menu. In this style tkPriv(postedMb) is empty and # the top-level menu is override-redirect. # # The various binding procedures use the state described above to # distinguish the various cases and take different actions in each # case. #------------------------------------------------------------------------- # tkMenuBind -- # This procedure is invoked the first time the mouse enters a menubutton # widget or a menubutton widget receives the input focus. It creates # all of the class bindings for both menubuttons and menus. # # Arguments: # w - The widget that was just entered or just received # the input focus. # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. proc tkMenuBind {w event} { bind Menubutton {} bind Menubutton { tkMbEnter %W } bind Menubutton { tkMbLeave %W } bind Menubutton <1> { if {$tkPriv(inMenubutton) != ""} { tkMbPost $tkPriv(inMenubutton) %X %Y } } bind Menubutton { tkMbMotion %W up %X %Y } bind Menubutton { tkMbMotion %W down %X %Y } bind Menubutton { tkMbButtonUp %W } bind Menubutton { tkMbPost %W tkMenuFirstEntry [%W cget -menu] } bind Menubutton { tkMbPost %W tkMenuFirstEntry [%W cget -menu] } # Must set focus when mouse enters a menu, in order to allow # mixed-mode processing using both the mouse and the keyboard. bind Menu {} bind Menu { set tkPriv(window) %W focus %W } bind Menu { tkMenuLeave %W %X %Y %s } bind Menu { tkMenuMotion %W %y %s } bind Menu { tkMenuButtonDown %W } bind Menu { tkMenuInvoke %W } bind Menu { tkMenuInvoke %W } bind Menu { tkMenuInvoke %W } bind Menu { tkMenuEscape %W } bind Menu { tkMenuLeftRight %W left } bind Menu { tkMenuLeftRight %W right } bind Menu { tkMenuNextEntry %W -1 } bind Menu { tkMenuNextEntry %W +1 } bind Menu { tkTraverseWithinMenu %W %A } if {($event == "Enter") && ([winfo class $w] == "Menubutton")} { tkMbEnter $w } } # tkMbEnter -- # This procedure is invoked when the mouse enters a menubutton # widget. It activates the widget unless it is disabled. Note: # this procedure is only invoked when mouse button 1 is *not* down. # The procedure tkMbB1Enter is invoked if the button is down. # # Arguments: # w - The name of the widget. proc tkMbEnter w { global tkPriv tk_strictMotif set tkPriv(inMenubutton) $w if {([$w cget -state] != "disabled") && !$tk_strictMotif} { $w configure -state active } } # tkMbLeave -- # This procedure is invoked when the mouse leaves a menubutton widget. # It de-activates the widget. # # Arguments: # w - The name of the widget. proc tkMbLeave w { global tkPriv tk_strictMotif set tkPriv(inMenubutton) {} if {[$w cget -state] == "active"} { $w configure -state normal } } # tkMbPost -- # Given a menubutton, this procedure does all the work of posting # its associated menu and unposting any other menu that is currently # posted. # # Arguments: # w - The name of the menubutton widget whose menu # is to be posted. # x, y - Root coordinates of cursor, used for positioning # option menus. If not specified, then the center # of the menubutton is used for an option menu. proc tkMbPost {w {x {}} {y {}}} { global tkPriv tk_strictMotif if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} { return } set menu [$w cget -menu] if {$menu == ""} { return } if ![string match $w.* $menu] { error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" } set cur $tkPriv(postedMb) if {$cur != ""} { tkMenuUnpost {} } set tkPriv(cursor) [$w cget -cursor] set tkPriv(relief) [$w cget -relief] $w configure -cursor arrow $w configure -relief raised set tkPriv(postedMb) $w set tkPriv(focus) [focus] $menu activate none # If this looks like an option menubutton then post the menu so # that the current entry is on top of the mouse. Otherwise post # the menu just below the menubutton, as for a pull-down. if {([$w cget -indicatoron] == 1) && ([$w cget -textvariable] != "")} { if {$y == ""} { set x [expr [winfo rootx $w] + [winfo width $w]/2] set y [expr [winfo rooty $w] + [winfo height $w]/2] } tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]] } else { $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]] } focus $menu grab -global $w } # tkMenuUnpost -- # This procedure unposts a given menu, plus all of its ancestors up # to (and including) a menubutton, if any. It also restores various # values to what they were before the menu was posted, and releases # a grab if there's a menubutton involved. Special notes: # 1. It's important to unpost all menus before releasing the grab, so # that any Enter-Leave events (e.g. from menu back to main # application) have mode NotifyGrab. # 2. Be sure to enclose various groups of commands in "catch" so that # the procedure will complete even if the menubutton or the menu # or the grab window has been deleted. # # Arguments: # menu - Name of a menu to unpost. Ignored if there # is a posted menubutton. proc tkMenuUnpost menu { global tkPriv set mb $tkPriv(postedMb) # Unpost menu(s) and restore some stuff that's dependent on # what was posted. catch { if {$mb != ""} { set menu [$mb cget -menu] $menu unpost set tkPriv(postedMb) {} $mb configure -cursor $tkPriv(cursor) $mb configure -relief $tkPriv(relief) } elseif {$tkPriv(popup) != ""} { $tkPriv(popup) unpost set tkPriv(popup) {} } elseif {[wm overrideredirect $menu]} { # We're in a cascaded sub-menu from a torn-off menu or popup. # Unpost all the menus up to the toplevel one (but not # including the top-level torn-off one) and deactivate the # top-level torn off menu if there is one. while 1 { set parent [winfo parent $menu] if {[winfo class $parent] != "Menu"} { break } $parent activate none if {![wm overrideredirect $parent]} { break } set menu $parent } $menu unpost } } # Restore focus and release grab, if any. catch {focus $tkPriv(focus)} set tkPriv(focus) "" if {$menu != ""} { set grab [grab current $menu] if {$grab != ""} { grab release $grab } } } # tkMbMotion -- # This procedure handles mouse motion events inside menubuttons, and # also outside menubuttons when a menubutton has a grab (e.g. when a # menu selection operation is in progress). # # Arguments: # w - The name of the menubutton widget. # upDown - "down" means button 1 is pressed, "up" means # it isn't. # rootx, rooty - Coordinates of mouse, in (virtual?) root window. proc tkMbMotion {w upDown rootx rooty} { global tkPriv if {$tkPriv(inMenubutton) == $w} { return } set new [winfo containing $rootx $rooty] if {($new != $tkPriv(inMenubutton)) && ($tkPriv(inMenubutton) != "")} { tkMbLeave $tkPriv(inMenubutton) } if {($new != "") && ([winfo class $new] == "Menubutton")} { if {$upDown == "down"} { tkMbPost $new $rootx $rooty } else { tkMbEnter $new } } } # tkMbButtonUp -- # This procedure is invoked to handle button 1 releases for menubuttons. # If the release happens inside the menubutton then leave its menu # posted with element 0 activated. Otherwise, unpost the menu. # # Arguments: # w - The name of the menubutton widget. proc tkMbButtonUp w { global tkPriv if {($tkPriv(postedMb) == $w) && ($tkPriv(inMenubutton) == $w)} { tkMenuFirstEntry [$tkPriv(postedMb) cget -menu] } else { tkMenuUnpost {} } } # tkMenuMotion -- # This procedure is called to handle mouse motion events for menus. # It does two things. First, it resets the active element in the # menu, if the mouse is over the menu. Second, if the new active # element is a cascade entry then it invokes the element, as long # as there is a button pressed. # # Arguments: # menu - The menu window. # y - The y position of the mouse. # state - Modifier state (tells whether buttons are down). proc tkMenuMotion {menu y state} { global tkPriv if {$menu == $tkPriv(window)} { $menu activate @$y } if {([$menu type active] == "cascade") && (($state & 0x1f00) != 0)} { $menu invoke active } } # tkMenuButtonDown -- # Handles button presses in menus. There are a couple of tricky things # here: # 1. If the active element is a cascade entry, invoke it just to make # sure that the submenu is posted (it might not be posted already). # 2. If there is a posted menubutton, must grab to the menubutton so # that it can track mouse motions over other menu buttons and change # the posted menu. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu # or one of its descendants) must grab to the top-level menu so that # we can track mouse motions across the entire menu hierarchy. # # Arguments: # menu - The menu window. proc tkMenuButtonDown menu { global tkPriv if {[$menu type active] == "cascade"} { $menu invoke active } if {$tkPriv(postedMb) != ""} { grab -global $tkPriv(postedMb) } else { while {[wm overrideredirect $menu] && [winfo class [winfo parent $menu]] == "Menu"} { set menu [winfo parent $menu] } grab -global $menu } } # tkMenuLeave -- # This procedure is invoked to handle Leave events for a menu. It # deactivates everything unless the active element is a cascade element # and the mouse is now over the submenu. # # Arguments: # menu - The menu window. # rootx, rooty - Root coordinates of mouse. # state - Modifier state. proc tkMenuLeave {menu rootx rooty state} { global tkPriv set tkPriv(window) {} if {[$menu index active] == "none"} { return } if {([$menu type active] == "cascade") && ([winfo containing $rootx $rooty] == [$menu entrycget active -menu])} { return } $menu activate none } # tkMenuInvoke -- # This procedure is invoked when button 1 is released over a menu. # It invokes the appropriate menu action and unposts the menu if # it came from a menubutton. # # Arguments: # w - Name of the menu widget. proc tkMenuInvoke w { if {[$w type active] == "cascade"} { $w invoke active set menu [$w entrycget active -menu] tkMenuFirstEntry $menu } elseif {[$w type active] == "tearoff"} { tkMenuUnpost $w tkTearOffMenu $w } else { tkMenuUnpost $w $w invoke active } } # tkMenuEscape -- # This procedure is invoked for the Cancel (or Escape) key. It unposts # the given menu and, if it is the top-level menu for a menu button, # unposts the menu button as well. # # Arguments: # menu - Name of the menu window. proc tkMenuEscape menu { if {[winfo class [winfo parent $menu]] != "Menu"} { tkMenuUnpost $menu } else { tkMenuLeftRight $menu -1 } } # tkMenuLeftRight -- # This procedure is invoked to handle "left" and "right" traversal # motions in menus. It traverses to the next menu in a menu bar, # or into or out of a cascaded menu. # # Arguments: # menu - The menu that received the keyboard # event. # direction - Direction in which to move: "left" or "right" proc tkMenuLeftRight {menu direction} { global tkPriv # First handle traversals into and out of cascaded menus. if {$direction == "right"} { set count 1 if {[$menu type active] == "cascade"} { $menu invoke active set m2 [$menu entrycget active -menu] if {$m2 != ""} { tkMenuFirstEntry $m2 } return } } else { set count -1 set m2 [winfo parent $menu] if {[winfo class $m2] == "Menu"} { $menu activate none focus $m2 # This code unposts any posted submenu in the parent. set tmp [$m2 index active] $m2 activate none $m2 activate $tmp return } } # Can't traverse into or out of a cascaded menu. Go to the next # or previous menubutton, if that makes sense. set w $tkPriv(postedMb) if {$w == ""} { return } set buttons [winfo children [winfo parent $w]] set length [llength $buttons] set i [expr [lsearch -exact $buttons $w] + $count] while 1 { while {$i < 0} { incr i $length } while {$i >= $length} { incr i -$length } set mb [lindex $buttons $i] if {([winfo class $mb] == "Menubutton") && ([$mb cget -state] != "disabled")} { break } if {$mb == $w} { return } incr i $count } tkMbPost $mb tkMenuFirstEntry [$mb cget -menu] } # tkMenuNextEntry -- # Activate the next higher or lower entry in the posted menu, # wrapping around at the ends. Disabled entries are skipped. # # Arguments: # menu - Menu window that received the keystroke. # count - 1 means go to the next lower entry, # -1 means go to the next higher entry. proc tkMenuNextEntry {menu count} { global tkPriv if {[$menu index last] == "none"} { return } set length [expr [$menu index last]+1] set active [$menu index active] if {$active == "none"} { set i 0 } else { set i [expr $active + $count] } while 1 { while {$i < 0} { incr i $length } while {$i >= $length} { incr i -$length } if {[catch {$menu entrycget $i -state} state] == 0} { if {$state != "disabled"} { break } } if {$i == $active} { return } incr i $count } $menu activate $i } # tkMenuFind -- # This procedure searches the entire window hierarchy under w for # a menubutton that isn't disabled and whose underlined character # is "char". It returns the name of that window, if found, or an # empty string if no matching window was found. If "char" is an # empty string then the procedure returns the name of the first # menubutton found that isn't disabled. # # Arguments: # w - Name of window where key was typed. # char - Underlined character to search for; # may be either upper or lower case, and # will match either upper or lower case. proc tkMenuFind {w char} { global tkPriv set char [string tolower $char] foreach child [winfo child $w] { switch [winfo class $child] { Menubutton { set char2 [string index [$child cget -text] \ [$child cget -underline]] if {([string compare $char [string tolower $char2]] == 0) || ($char == "")} { if {[$child cget -state] != "disabled"} { return $child } } } Frame { set match [tkMenuFind $child $char] if {$match != ""} { return $match } } } } return {} } # tkTraverseToMenu -- # This procedure implements keyboard traversal of menus. Given an # ASCII character "char", it looks for a menubutton with that character # underlined. If one is found, it posts the menubutton's menu # # Arguments: # w - Window in which the key was typed (selects # a toplevel window). # char - Character that selects a menu. The case # is ignored. If an empty string, nothing # happens. proc tkTraverseToMenu {w char} { if {$char == ""} { return } set w [tkMenuFind [winfo toplevel $w] $char] if {$w != ""} { tkMbPost $w tkMenuFirstEntry [$w cget -menu] } } # tkFirstMenu -- # This procedure traverses to the first menubutton in the toplevel # for a given window, and posts that menubutton's menu. # # Arguments: # w - Name of a window. Selects which toplevel # to search for menubuttons. proc tkFirstMenu w { set w [tkMenuFind [winfo toplevel $w] ""] if {$w != ""} { tkMbPost $w tkMenuFirstEntry [$w cget -menu] } } # tkTraverseWithinMenu # This procedure implements keyboard traversal within a menu. It # searches for an entry in the menu that has "char" underlined. If # such an entry is found, it is invoked and the menu is unposted. # # Arguments: # w - The name of the menu widget. # char - The character to look for; case is # ignored. If the string is empty then # nothing happens. proc tkTraverseWithinMenu {w char} { if {$char == ""} { return } set char [string tolower $char] set last [$w index last] if {$last == "none"} { return } for {set i 0} {$i <= $last} {incr i} { if [catch {set char2 [string index \ [$w entrycget $i -label] \ [$w entrycget $i -underline]]}] { continue } if {[string compare $char [string tolower $char2]] == 0} { tkMenuUnpost $w $w invoke $i return } } } # tkMenuFirstEntry -- # Given a menu, this procedure finds the first entry that isn't # disabled or a tear-off or separator, and activates that entry. # However, if there is already an active entry in the menu (e.g., # because of a previous call to tkPostOverPoint) then the active # entry isn't changed. This procedure also sets the input focus # to the menu. # # Arguments: # menu - Name of the menu window (possibly empty). proc tkMenuFirstEntry menu { if {$menu == ""} { return } focus $menu if {[$menu index active] != "none"} { return } set last [$menu index last] for {set i 0} {$i <= $last} {incr i} { if {([catch {set state [$menu entrycget $i -state]}] == 0) && ($state != "disabled") && ([$menu type $i] != "tearoff")} { $menu activate $i return } } } # tkMenuFindName -- # Given a menu and a text string, return the index of the menu entry # that displays the string as its label. If there is no such entry, # return an empty string. This procedure is tricky because some names # like "active" have a special meaning in menu commands, so we can't # always use the "index" widget command. # # Arguments: # menu - Name of the menu widget. # s - String to look for. proc tkMenuFindName {menu s} { set i "" if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} { catch {set i [$menu index $s]} return $i } set last [$menu index last] for {set i 0} {$i <= $last} {incr i} { if ![catch {$menu entrycget $i -label} label] { if {$label == $s} { return $i } } } return "" } # tkPostOverPoint -- # This procedure posts a given menu such that a given entry in the # menu is centered over a given point in the root window. It also # activates the given entry. # # Arguments: # menu - Menu to post. # x, y - Root coordinates of point. # entry - Index of entry within menu to center over (x,y). # If omitted or specified as {}, then the menu's # upper-left corner goes at (x,y). proc tkPostOverPoint {menu x y {entry {}}} { if {$entry != {}} { if {$entry == [$menu index last]} { incr y [expr -([$menu yposition $entry] + [winfo height $menu])/2] } else { incr y [expr -([$menu yposition $entry] \ + [$menu yposition [expr $entry+1]])/2] } incr x [expr -[winfo reqwidth $menu]/2] } $menu post $x $y if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} { $menu activate $entry } } # tk_popup -- # This procedure pops up a menu and sets things up for traversing # the menu and its submenus. # # Arguments: # menu - Name of the menu to be popped up. # x, y - Root coordinates at which to pop up the # menu. # entry - Index of a menu entry to center over (x,y). # If omitted or specified as {}, then menu's # upper-left corner goes at (x,y). proc tk_popup {menu x y {entry {}}} { global tkPriv if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} { tkMenuUnpost {} } tkPostOverPoint $menu $x $y $entry grab -global $menu set tkPriv(popup) $menu set tkPriv(focus) [focus] focus $menu } WWW/TkWWW/Tcl/library/obsolete.tcl100664 7006 0 1407 5722532032 15546 0ustar joesystem# obsolete.tcl -- # # This file contains obsolete procedures that people really shouldn't # be using anymore, but which are kept around for backward compatibility. # # @(#) obsolete.tcl 1.2 94/12/17 16:05:21 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # The procedures below are here strictly for backward compatibility with # Tk version 3.6 and earlier. The procedures are no longer needed, so # they are no-ops. You should not use these procedures anymore, since # they may be removed in some future release. proc tk_menuBar args {} proc tk_bindForTraversal args {} WWW/TkWWW/Tcl/library/optionMenu.tcl100664 7006 0 3202 5722532033 16063 0ustar joesystem# optionMenu.tcl -- # # This file defines the procedure tk_optionMenu, which creates # an option button and its associated menu. # # @(#) optionMenu.tcl 1.6 95/01/06 11:18:53 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tk_optionMenu -- # This procedure creates an option button named $w and an associated # menu. Together they provide the functionality of Motif option menus: # they can be used to select one of many values, and the current value # appears in the global variable varName, as well as in the text of # the option menubutton. The name of the menu is returned as the # procedure's result, so that the caller can use it to change configuration # options on the menu or otherwise manipulate it. # # Arguments: # w - The name to use for the menubutton. # varName - Global variable to hold the currently selected value. # firstValue - First of legal values for option (must be >= 1). # args - Any number of additional values. proc tk_optionMenu {w varName firstValue args} { upvar #0 $varName var if ![info exists var] { set var $firstValue } menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ -relief raised -bd 2 -padx 4p -pady 4p -highlightthickness 2 \ -anchor c menu $w.menu -tearoff 0 $w.menu add command -label $firstValue \ -command [list set $varName $firstValue] foreach i $args { $w.menu add command -label $i -command [list set $varName $i] } return $w.menu } WWW/TkWWW/Tcl/library/parray.tcl100664 7006 0 1464 5722532024 15234 0ustar joesystem# parray: # Print the contents of a global array on stdout. # # @(#) parray.tcl 1.7 95/01/04 15:21:24 # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # proc parray a { upvar 1 $a array if ![array exists array] { error "\"$a\" isn't an array" } set maxl 0 foreach name [lsort [array names array]] { if {[string length $name] > $maxl} { set maxl [string length $name] } } set maxl [expr {$maxl + [string length $a] + 2}] foreach name [lsort [array names array]] { set nameString [format %s(%s) $a $name] puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] } } WWW/TkWWW/Tcl/library/scale.tcl100664 7006 0 15054 5722532033 15045 0ustar joesystem# scale.tcl -- # # This file defines the default bindings for Tk scale widgets. # # @(#) scale.tcl 1.3 94/12/17 16:05:23 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkScaleBind -- # This procedure below invoked the first time the mouse enters a # scale widget or a scale widget receives the input focus. It creates # all of the class bindings for scales. # # Arguments: # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. proc tkScaleBind {{event {}}} { bind Scale {} # Standard Motif bindings: bind Scale { if $tk_strictMotif { set tkPriv(activeBg) [%W cget -activebackground] %W config -activebackground [%W cget -background] } tkScaleActivate %W %x %y } bind Scale { tkScaleActivate %W %x %y } bind Scale { if $tk_strictMotif { %W config -activebackground $tkPriv(activeBg) } if {[%W cget -state] == "active"} { %W configure -state normal } } bind Scale <1> { tkScaleButtonDown %W %x %y } bind Scale { tkScaleDrag %W %x %y } bind Scale { } bind Scale { } bind Scale { tkCancelRepeat tkScaleEndDrag %W %x %y tkScaleActivate %W %x %y } bind Scale <2> { tkScaleButtonDown %W %x %y } bind Scale { tkScaleDrag %W %x %y } bind Scale { } bind Scale { } bind Scale { tkCancelRepeat tkScaleEndDrag %W %x %y tkScaleActivate %W %x %y } bind Scale { tkScaleControlPress %W %x %y } bind Scale { tkScaleIncrement %W up little noRepeat } bind Scale { tkScaleIncrement %W down little noRepeat } bind Scale { tkScaleIncrement %W up little noRepeat } bind Scale { tkScaleIncrement %W down little noRepeat } bind Scale { tkScaleIncrement %W up big noRepeat } bind Scale { tkScaleIncrement %W down big noRepeat } bind Scale { tkScaleIncrement %W up big noRepeat } bind Scale { tkScaleIncrement %W down big noRepeat } bind Scale { %W set [%W cget -from] } bind Scale { %W set [%W cget -to] } rename tkScaleBind {} } # tkScaleActivate -- # This procedure is invoked to check a given x-y position in the # scale and activate the slider if the x-y position falls within # the slider. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates. proc tkScaleActivate {w x y} { global tkPriv if {[$w cget -state] == "disabled"} { return; } if {[$w identify $x $y] == "slider"} { $w configure -state active } else { $w configure -state normal } } # tkScaleButtonDown -- # This procedure is invoked when a button is pressed in a scale. It # takes different actions depending on where the button was pressed. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates of button press. proc tkScaleButtonDown {w x y} { global tkPriv set tkPriv(dragging) 0 set el [$w identify $x $y] if {$el == "trough1"} { tkScaleIncrement $w up little initial } elseif {$el == "trough2"} { tkScaleIncrement $w down little initial } elseif {$el == "slider"} { set tkPriv(dragging) 1 set tkPriv(initValue) [$w get] set coords [$w coords] set tkPriv(deltaX) [expr $x - [lindex $coords 0]] set tkPriv(deltaY) [expr $y - [lindex $coords 1]] } } # tkScaleDrag -- # This procedure is called when the mouse is dragged with # mouse button 1 down. If the drag started inside the slider # (i.e. the scale is active) then the scale's value is adjusted # to reflect the mouse's position. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates. proc tkScaleDrag {w x y} { global tkPriv if !$tkPriv(dragging) { return } $w set [$w get [expr $x - $tkPriv(deltaX)] \ [expr $y - $tkPriv(deltaY)]] } # tkScaleEndDrag -- # This procedure is called to end an interactive drag of the # slider. If the mouse is far from the window then it just # restores the scale's value to what it was at the start of # the drag. # # Arguments: # w - The scale widget. # x, y - The mouse position at the end of the drag. proc tkScaleEndDrag {w x y} { global tkPriv if !$tkPriv(dragging) { return } set tkPriv(dragging) 0 if {($x < -10) || ($y < -10) || ($x > ([winfo width $w] + 10)) || ($y > ([winfo height $w] + 10))} { $w set $tkPriv(initValue) } } # tkScaleIncrement -- # This procedure is invoked to increment the value of a scale and # to set up auto-repeating of the action if that is desired. The # way the value is incremented depends on the "dir" and "big" # arguments. # # Arguments: # w - The scale widget. # dir - "up" means move value towards -from, "down" means # move towards -to. # big - Size of increments: "big" or "little". # repeat - Whether and how to auto-repeat the action: "noRepeat" # means don't auto-repeat, "initial" means this is the # first action in an auto-repeat sequence, and "again" # means this is the second repetition or later. proc tkScaleIncrement {w dir big repeat} { global tkPriv if {$big == "big"} { set inc [$w cget -bigincrement] if {$inc == 0} { set inc [expr abs([$w cget -to] - [$w cget -from])/10.0] } if {$inc < [$w cget -resolution]} { set inc [$w cget -resolution] } } else { set inc [$w cget -resolution] } if {([$w cget -from] > [$w cget -to]) ^ ($dir == "up")} { set inc [expr -$inc] } $w set [expr [$w get] + $inc] if {$repeat == "again"} { set tkPriv(afterId) [after [$w cget -repeatinterval] \ tkScaleIncrement $w $dir $big again] } elseif {$repeat == "initial"} { set tkPriv(afterId) [after [$w cget -repeatdelay] \ tkScaleIncrement $w $dir $big again] } } # tkScaleControlPress -- # This procedure handles button presses that are made with the Control # key down. Depending on the mouse position, it adjusts the scale # value to one end of the range or the other. # # Arguments: # w - The scale widget. # x, y - Mouse coordinates where the button was pressed. proc tkScaleControlPress {w x y} { set el [$w identify $x $y] if {$el == "trough1"} { $w set [$w cget -from] } elseif {$el == "trough2"} { $w set [$w cget -to] } } WWW/TkWWW/Tcl/library/scrollbar.tcl100664 7006 0 24642 5722532034 15745 0ustar joesystem# scrollbar.tcl -- # # This file defines the default bindings for Tk scrollbar widgets. # # @(#) scrollbar.tcl 1.7 95/01/05 08:51:48 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkScrollbarBind -- # This procedure below invoked the first time the mouse enters a # scrollbar widget or an scrollbar widget receives the input focus. It # creates all of the class bindings for scrollbars. # # Arguments: # w - The event in which the window occurred. # x, y - Coordinates of the mouse. # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. proc tkScrollbarBind {w x y {event {}}} { global tk_strictMotif tkPriv bind Scrollbar {} # Standard Motif bindings: bind Scrollbar { if $tk_strictMotif { set tkPriv(activeBg) [%W cget -activebackground] %W config -activebackground [%W cget -background] } %W activate [%W identify %x %y] } # If the event that triggered us was an Enter, execute the new # contents of the Enter binding directly, since the binding won't # be run automatically until the next Enter event. if {$event == "Enter"} { if $tk_strictMotif { set tkPriv(activeBg) [$w cget -activebackground] $w config -activebackground [$w cget -background] } $w activate [$w identify $x $y] } bind Scrollbar { %W activate [%W identify %x %y] } bind Scrollbar { if $tk_strictMotif { %W config -activebackground $tkPriv(activeBg) } %W activate {} } bind Scrollbar <1> { tkScrollButtonDown %W %x %y } bind Scrollbar { tkScrollDrag %W %x %y } bind Scrollbar { tkScrollButtonUp %W %x %y } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar <2> { tkScrollButtonDown %W %x %y } bind Scrollbar { tkScrollDrag %W %x %y } bind Scrollbar { tkScrollButtonUp %W %x %y } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { # Prevents binding from being invoked. } bind Scrollbar { tkScrollTopBottom %W %x %y } bind Scrollbar { tkScrollTopBottom %W %x %y } bind Scrollbar { tkScrollByUnits %W v -1 } bind Scrollbar { tkScrollByUnits %W v 1 } bind Scrollbar { tkScrollByPages %W v -1 } bind Scrollbar { tkScrollByPages %W v 1 } bind Scrollbar { tkScrollByUnits %W h -1 } bind Scrollbar { tkScrollByUnits %W h 1 } bind Scrollbar { tkScrollByPages %W h -1 } bind Scrollbar { tkScrollByPages %W h 1 } bind Scrollbar { tkScrollByPages %W hv -1 } bind Scrollbar { tkScrollByPages %W hv 1 } bind Scrollbar { tkScrollToPos %W 0 } bind Scrollbar { tkScrollToPos %W 1 } rename tkScrollbarBind {} } # tkScrollButtonDown -- # This procedure is invoked when a button is pressed in a scrollbar. # It changes the way the scrollbar is displayed and takes actions # depending on where the mouse is. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates. proc tkScrollButtonDown {w x y} { $w configure -activerelief sunken set element [$w identify $x $y] if {$element == "slider"} { tkScrollStartDrag $w $x $y } else { tkScrollSelect $w $element initial } } # tkScrollButtonUp -- # This procedure is invoked when a button is released in a scrollbar. # It cancels scans and auto-repeats that were in progress, and restores # the way the active element is displayed. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates. proc tkScrollButtonUp {w x y} { tkCancelRepeat $w configure -activerelief raised tkScrollEndDrag $w $x $y $w activate [$w identify $x $y] } # tkScrollSelect -- # This procedure is invoked when button 1 is pressed over the scrollbar. # It invokes one of several scrolling actions depending on where in # the scrollbar the button was pressed. # # Arguments: # w - The scrollbar widget. # element - The element of the scrollbar that was selected, such # as "arrow1" or "trough2". Shouldn't be "slider". # repeat - Whether and how to auto-repeat the action: "noRepeat" # means don't auto-repeat, "initial" means this is the # first action in an auto-repeat sequence, and "again" # means this is the second repetition or later. proc tkScrollSelect {w element repeat} { global tkPriv if {$element == "arrow1"} { tkScrollByUnits $w hv -1 } elseif {$element == "trough1"} { tkScrollByPages $w hv -1 } elseif {$element == "trough2"} { tkScrollByPages $w hv 1 } elseif {$element == "arrow2"} { tkScrollByUnits $w hv 1 } else { return } if {$repeat == "again"} { set tkPriv(afterId) [after [$w cget -repeatinterval] \ tkScrollSelect $w $element again] } elseif {$repeat == "initial"} { set tkPriv(afterId) [after [$w cget -repeatdelay] \ tkScrollSelect $w $element again] } } # tkScrollStartDrag -- # This procedure is called to initiate a drag of the slider. It just # remembers the starting position of the slider. # # Arguments: # w - The scrollbar widget. # x, y - The mouse position at the start of the drag operation. proc tkScrollStartDrag {w x y} { global tkPriv if {[$w cget -command] == ""} { return } set tkPriv(initMouse) [$w fraction $x $y] set tkPriv(initValues) [$w get] if {[llength $tkPriv(initValues)] == 2} { set tkPriv(initPos) [lindex $tkPriv(initValues) 0] } else { set tkPriv(initPos) [expr (double([lindex $tkPriv(initValues) 2])) \ / [lindex $tkPriv(initValues) 0]] } } # tkScrollDrag -- # This procedure is called for each mouse motion even when the slider # is being dragged. It notifies the associated widget if we're not # jump scrolling, and it just updates the scrollbar if we are jump # scrolling. # # Arguments: # w - The scrollbar widget. # x, y - The current mouse position. proc tkScrollDrag {w x y} { global tkPriv if {$tkPriv(initMouse) == ""} { return } set f [$w fraction $x $y] set delta [expr $f - $tkPriv(initMouse)] if [$w cget -jump] { if {[llength $tkPriv(initValues)] == 2} { $w set [expr [lindex $tkPriv(initValues) 0] + $delta] \ [expr [lindex $tkPriv(initValues) 1] + $delta] } else { set delta [expr round($delta * [lindex $tkPriv(initValues) 0])] eval $w set [lreplace $tkPriv(initValues) 2 3 \ [expr [lindex $tkPriv(initValues) 2] + $delta] \ [expr [lindex $tkPriv(initValues) 3] + $delta]] } } else { tkScrollToPos $w [expr $tkPriv(initPos) + $delta] } } # tkScrollEndDrag -- # This procedure is called to end an interactive drag of the slider. # If the mouse is far from the window then it just restores the position # to what it was at the start of the drag; otherwise it scrolls the # window if we're in jump mode, otherwise it does nothing. # # Arguments: # w - The scrollbar widget. # x, y - The mouse position at the end of the drag operation. proc tkScrollEndDrag {w x y} { global tkPriv if {$tkPriv(initMouse) == ""} { return } if {($x < -10) || ($y < -10) || ($x > ([winfo width $w] + 10)) || ($y > ([winfo height $w] + 10))} { if [$w cget -jump] { eval $w set $tkPriv(initValues) } else { tkScrollToPos $w $tkPriv(initPos) } } elseif [$w cget -jump] { tkScrollToPos $w [expr $tkPriv(initPos) + [$w fraction $x $y] \ - $tkPriv(initMouse)] } set tkPriv(initMouse) "" } # tkScrollByUnits -- # This procedure tells the scrollbar's associated widget to scroll up # or down by a given number of units. It notifies the associated widget # in different ways for old and new command syntaxes. # # Arguments: # w - The scrollbar widget. # orient - Which kinds of scrollbars this applies to: "h" for # horizontal, "v" for vertical, "hv" for both. # amount - How many units to scroll: typically 1 or -1. proc tkScrollByUnits {w orient amount} { set cmd [$w cget -command] if {($cmd == "") || ([string first \ [string index [$w cget -orient] 0] $orient] < 0)} { return } set info [$w get] if {[llength $info] == 2} { eval $cmd scroll $amount units } else { eval $cmd [expr [lindex $info 2] + $amount] } } # tkScrollByPages -- # This procedure tells the scrollbar's associated widget to scroll up # or down by a given number of screenfuls. It notifies the associated # widget in different ways for old and new command syntaxes. # # Arguments: # w - The scrollbar widget. # orient - Which kinds of scrollbars this applies to: "h" for # horizontal, "v" for vertical, "hv" for both. # amount - How many screens to scroll: typically 1 or -1. proc tkScrollByPages {w orient amount} { set cmd [$w cget -command] if {($cmd == "") || ([string first \ [string index [$w cget -orient] 0] $orient] < 0)} { return } set info [$w get] if {[llength $info] == 2} { eval $cmd scroll $amount pages } else { eval $cmd [expr [lindex $info 2] + $amount*([lindex $info 1] - 1)] } } # tkScrollToPos -- # This procedure tells the scrollbar's associated widget to scroll to # a particular location, given by a fraction between 0 and 1. It notifies # the associated widget in different ways for old and new command syntaxes. # # Arguments: # w - The scrollbar widget. # pos - A fraction between 0 and 1 indicating a desired position # in the document. proc tkScrollToPos {w pos} { set cmd [$w cget -command] if {($cmd == "")} { return } set info [$w get] if {[llength $info] == 2} { eval $cmd moveto $pos } else { eval $cmd [expr round([lindex $info 0]*$pos)] } } # tkScrollTopBottom # Scroll to the top or bottom of the document, depending on the mouse # position. # # Arguments: # w - The scrollbar widget. # x, y - Mouse coordinates within the widget. proc tkScrollTopBottom {w x y} { set element [$w identify $x $y] if [string match *1 $element] { tkScrollToPos $w 0 } elseif [string match *2 $element] { tkScrollToPos $w 1 } } WWW/TkWWW/Tcl/library/tearoff.tcl100664 7006 0 6075 5722532035 15371 0ustar joesystem# tearoff.tcl -- # # This file contains procedures that implement tear-off menus. # # @(#) tearoff.tcl 1.3 94/12/17 16:05:25 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkTearoffMenu -- # Given the name of a menu, this procedure creates a torn-off menu # that is identical to the given menu (including nested submenus). # The new torn-off menu exists as a toplevel window managed by the # window manager. The return value is the name of the new menu. # # Arguments: # w - The menu to be torn-off (duplicated). proc tkTearOffMenu w { # Find a unique name to use for the torn-off menu. Find the first # ancestor of w that is a toplevel but not a menu, and use this as # the parent of the new menu. This guarantees that the torn off # menu will be on the same screen as the original menu. By making # it a child of the ancestor, rather than a child of the menu, it # can continue to live even if the menu is deleted; it will go # away when the toplevel goes away. set parent [winfo parent $w] while {([winfo toplevel $parent] != $parent) || ([winfo class $parent] == "Menu")} { set parent [winfo parent $parent] } if {$parent == "."} { set parent "" } for {set i 1} 1 {incr i} { set menu $parent.tearoff$i if ![winfo exists $menu] { break } } tkMenuDup $w $menu wm overrideredirect $menu 0 # Pick a title for the new menu by looking at the parent of the # original: if the parent is a menu, then use the text of the active # entry. If it's a menubutton then use its text. set parent [winfo parent $w] switch [winfo class $parent] { Menubutton { wm title $menu [$parent cget -text] } Menu { wm title $menu [$parent entrycget active -label] } } $menu configure -tearoff 0 $menu post [winfo x $w] [winfo y $w] # Set tkPriv(focus) on entry: otherwise the focus will get lost # after keyboard invocation of a sub-menu (it will stay on the # submenu). bind $menu { set tkPriv(focus) %W } } # tkMenuDup -- # Given a menu (hierarchy), create a duplicate menu (hierarchy) # in a given window. # # Arguments: # src - Source window. Must be a menu. It and its # menu descendants will be duplicated at dst. # dst - Name to use for topmost menu in duplicate # hierarchy. proc tkMenuDup {src dst} { set cmd "menu $dst" foreach option [$src configure] { if {[llength $option] == 2} { continue } lappend cmd [lindex $option 0] [lindex $option 4] } eval $cmd set last [$src index last] for {set i [$src cget -tearoff]} {$i <= $last} {incr i} { set cmd "$dst add [$src type $i]" foreach option [$src entryconfigure $i] { lappend cmd [lindex $option 0] [lindex $option 4] } eval $cmd if {[$src type $i] == "cascade"} { tkMenuDup [$src entrycget $i -menu] $dst.m$i $dst entryconfigure $i -menu $dst.m$i } } } WWW/TkWWW/Tcl/library/text.tcl100664 7006 0 45557 5722532036 14760 0ustar joesystem# text.tcl -- # # This file defines the default bindings for Tk text widgets. # # @(#) text.tcl 1.20 95/01/08 16:10:01 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkTextBind -- # This procedure below invoked the first time the mouse enters a text # widget or a text widget receives the input focus. It creates all of # the class bindings for texts. # # Arguments: # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. proc tkTextBind event { global tkPriv tk_strictMotif bind Text {} bind Text {} # Standard Motif bindings: bind Text <1> { tkTextButton1 %W %x %y %W tag remove sel 0.0 end } bind Text { set tkPriv(x) %x set tkPriv(y) %y tkTextSelectTo %W @%x,%y } bind Text { set tkPriv(selectMode) word tkTextSelectTo %W @%x,%y catch {%W mark set insert sel.first} } bind Text { set tkPriv(selectMode) line tkTextSelectTo %W @%x,%y catch {%W mark set insert sel.first} } bind Text { tkTextResetAnchor %W @%x,%y set tkPriv(selectMode) char tkTextSelectTo %W @%x,%y } bind Text { set tkPriv(selectMode) word tkTextSelectTo %W @%x,%y } bind Text { set tkPriv(selectMode) line tkTextSelectTo %W @%x,%y } bind Text { set tkPriv(x) %x set tkPriv(y) %y tkTextAutoScan %W } bind Text { tkCancelRepeat } bind Text { tkCancelRepeat } bind Text { %W mark set insert @%x,%y } bind Text { tkTextSetCursor %W [%W index {insert - 1c}] } bind Text { tkTextSetCursor %W [%W index {insert + 1c}] } bind Text { tkTextSetCursor %W [tkTextUpDownLine %W -1] } bind Text { tkTextSetCursor %W [tkTextUpDownLine %W 1] } bind Text { tkTextKeySelect %W [%W index {insert - 1c}] } bind Text { tkTextKeySelect %W [%W index {insert + 1c}] } bind Text { tkTextKeySelect %W [tkTextUpDownLine %W -1] } bind Text { tkTextKeySelect %W [tkTextUpDownLine %W 1] } bind Text { tkTextSetCursor %W [%W index {insert - 1c wordstart}] } bind Text { tkTextSetCursor %W [%W index {insert wordend}] } bind Text { tkTextSetCursor %W [tkTextPrevPara %W insert] } bind Text { tkTextSetCursor %W [tkTextNextPara %W insert] } bind Text { tkTextKeySelect %W [%W index {insert - 1c wordstart}] } bind Text { tkTextKeySelect %W [%W index {insert wordend}] } bind Text { tkTextKeySelect %W [tkTextPrevPara %W insert] } bind Text { tkTextKeySelect %W [tkTextNextPara %W insert] } bind Text { tkTextSetCursor %W [tkTextScrollPages %W -1] } bind Text { tkTextKeySelect %W [tkTextScrollPages %W -1] } bind Text { tkTextSetCursor %W [tkTextScrollPages %W 1] } bind Text { tkTextKeySelect %W [tkTextScrollPages %W 1] } bind Text { %W xview scroll -1 page } bind Text { %W xview scroll 1 page } bind Text { tkTextSetCursor %W {insert linestart} } bind Text { tkTextKeySelect %W {insert linestart} } bind Text { tkTextSetCursor %W {insert lineend} } bind Text { tkTextKeySelect %W {insert lineend} } bind Text { tkTextSetCursor %W 1.0 } bind Text { tkTextKeySelect %W 1.0 } bind Text { tkTextSetCursor %W {end - 1 char} } bind Text { tkTextKeySelect %W {end - 1 char} } bind Text { tkTextInsert %W \t focus %W break } bind Text { # Needed only to keep binding from triggering; doesn't # have to actually do anything. } bind Text { tk_focusNext %W } bind Text { tk_focusPrev %W } bind Text { tkTextInsert %W \t } bind Text { tkTextInsert %W \n } bind Text { if {[%W tag nextrange sel 1.0 end] != ""} { %W delete sel.first sel.last } else { %W delete insert %W see insert } } bind Text { if {[%W tag nextrange sel 1.0 end] != ""} { %W delete sel.first sel.last } elseif [%W compare insert != 1.0] { %W delete insert-1c %W see insert } } bind Text { %W mark set anchor insert } bind Text