/* * Epoch 4.0 - support code for buttons, styles, and display of attributed * text under X11. */ /* Copyright (C) 1985, 1986, 1987, 1988, 1989, 1990 Free Software Foundation, Inc. This file is part of Epoch, a modified version of GNU Emacs. Epoch is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY. No author or distributor accepts responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all, unless he says so in writing. Refer to the GNU Emacs General Public License for full details. Everyone is granted permission to copy, modify and redistribute Epoch, but only under the conditions described in the GNU Emacs General Public License. A copy of this license is supposed to have been given to you along with Epoch so you can know your rights and responsibilities. It should be in a file named COPYING. Among other things, the copyright notice and this notice must be preserved on all copies. */ /* * $Revision: 1.61 $ * $Source: /import/kaplan/stable/distrib/epoch-4.2/src/RCS/button.c,v $ * $Date: 92/08/01 22:35:11 $ * $Author: marca $ */ #ifndef LINT static char rcsid[] = "$Author: marca $ $Date: 92/08/01 22:35:11 $ $Source: /import/kaplan/stable/distrib/epoch-4.2/src/RCS/button.c,v $ $Revision: 1.61 $"; #endif #include #include /* get BLOCK_INPUT() right */ #include "config.h" #include "lisp.h" #include "x11term.h" #include "buffer.h" #include "window.h" /* X11 includes used; use NIL rather than NULL from lisp.h */ #include "screen.h" /* Epoch */ #include "screenW.h" /* Epoch */ #include "screenX.h" /* Epoch */ #include "dispepoch.h" /* Epoch */ #include "button.h" /* Epoch */ #include "xresource.h" /* Epoch */ #ifdef HAVE_GRAPHIC_ZONES #include "xpm.h" #endif #define min(a,b) ((a)<(b) ? (a) : (b)) #define max(a,b) ((a)>(b) ? (a) : (b)) extern Display *XD_display; /* default display */ extern int XD_plane; /* display plane */ extern int windows_or_buffers_changed; extern struct X_font *find_font(); extern short text_width(); extern Lisp_Object get_style_font(); extern struct X_font *font_list; Lisp_Object Vbuttons_modify_buffer; Lisp_Object Vmotion_style_overrides; /* this signals a read-only error if buttons-modify-buffer is set, and the * buffer is read-only. b is a buffer pointer, and buf should be the * Lisp_Object buffer corresponding to b */ #define CHECK_READ_ONLY(b,buf) { if (!NIL(Vbuttons_modify_buffer)\ && !((b == current_buffer) ? NIL(current_buffer->read_only) : NIL(b->read_only)))\ Fsignal(Qbuffer_read_only, (Fcons(buf,Qnil))); } #define MODIFY_BUFFER(b) { if (!EQ(Vbuttons_modify_buffer,Qnil))\ if (b == current_buffer) MODIFF+= 1;\ else BUF_MODIFF(b)+= 1;\ windows_or_buffers_changed++; } #ifdef HAVE_GRAPHIC_ZONES /* ------------------------------------------------------------------------- */ DEFUN ("epoch::define-opaque-font",Fdefine_opaque_font,Sdefine_opaque_font,3,4,0, "Define a new font called for use with graphic buttons. Font will\n\ have NAME, WIDTH, and HEIGHT. OFFSET is percentage of font to appear below\n\ baseline Return the name of the new font, or nil if failed.") (name,asc,width,offset) Lisp_Object name,asc,width; { struct X_font *f,*new; int off = 0,d; CHECK_STRING(name,0); CHECK_NUMBER(asc,0); CHECK_NUMBER(width,0); if (INTEGERP(offset)) off = XFASTINT(offset); off = off % 100; d = XFASTINT(asc) * off / 100; f = font_list; while (f && strcmp(f->font_name,XSTRING(name)->data)) f = f->next; /* Return t if font has been defined with same dimensions; else nil */ if (f) return ((XFWIDTH(f) == XFASTINT(width)) && (XFHEIGHT(f) == XFASTINT(asc)) && (XFDESCENT(f) == d)) ? build_string(f->font_name) : Qnil; new = (struct X_font *) malloc(sizeof (struct X_font)); new->font_name = (char *) strdup(XSTRING(name)->data); new->ascent = XFASTINT(asc) - d; new->descent = d; new->width = XFASTINT(width); new->variable = 0; /* Fixed */ new->virtual = 1; new->next = font_list; font_list = new; return build_string(new->font_name); } DEFUN ("epoch::read-pixmap-file", Fread_pixmap_file, Sread_pixmap_file,1,1,0, "Read FILE as an Xpm file and create the corresponding pixmap\n\ Return an Xresource of type Pixmap, or nil of errors encountered") (file) Lisp_Object file; { Pixmap pixmap,mask; XpmAttributes attributes; int status; Lisp_Object pix; char *pixname; XpmColorSymbol symbols[10]; BLOCK_INPUT_DECLARE(); if (XRESOURCEP(file)) return file; CHECK_STRING(file,0); pixname = (char *) strdup(XSTRING(file)->data); attributes.valuemask = XpmReturnInfos | XpmReturnPixels; attributes.colorsymbols = symbols; attributes.numsymbols = 0; attributes.colorTable = (char***)0; attributes.hints_cmt = (char*)0; attributes.colors_cmt = (char*)0; attributes.pixels_cmt = (char*)0; attributes.pixels = (Pixel*)0; BLOCK_INPUT(); status = XpmReadFileToPixmap(XD_display,cur_Xscreen->xid, pixname, &pixmap, &mask, &attributes); UNBLOCK_INPUT(); if (status != XpmSuccess) return Qnil; pix = make_Xresource(XD_display,XD_plane,pixmap,XA_PIXMAP); return pix; } DEFUN ("epoch::query-pixmap",Fquery_pixmap,Squery_pixmap,1,1,0, "Return information regarding PIXMAP. Return a list \n\ (width height depth).") (pix) Lisp_Object pix; { unsigned int width, height, border_width,depth; int x,y, status; Window root; BLOCK_INPUT_DECLARE(); CHECK_XRESOURCE(pix,0); BLOCK_INPUT(); status = XGetGeometry(XD_display, XXRESOURCE(pix)->id, &root, &x,&y, &width, &height, &border_width, &depth); UNBLOCK_INPUT(); return Fcons(make_number(width), Fcons(make_number(height), Fcons(make_number(depth), Qnil))); } #endif /* ------------------------------------------------------------------------- */ DEFUN ("epoch::make-zone",Fmake_button,Smake_button,0,0,0, "(epoch::make-zone) makes a zone pointing nowhere".) () { Lisp_Object val; register struct Lisp_Button *p; val = Fmake_vector (make_number((sizeof (struct Lisp_Button) - sizeof (struct Lisp_Vector) + sizeof (Lisp_Object)) / sizeof (Lisp_Object)), Qnil); XSETTYPE (val, Lisp_Button); p = XBUTTON(val); p->start = Fmake_marker(); p->end = Fmake_marker(); p->style = Qnil; /* don't need to set other fields to Qnil, done by Fmake_vector */ return val; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zones-at",Fbuttons_at,Sbuttons_at,0,2,0, "Returns a list of all zones in buffer intersecting given point.") (pos, buffer) Lisp_Object pos, buffer; { register struct buffer *bf1; register struct Lisp_Button *button; register Lisp_Object buttons,b_list; register int ipos; /* Check for valid buffer, or get current */ buffer = NIL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer); CHECK_BUFFER(buffer,0); bf1 = XBUFFER(buffer); if (EQ(pos,Qnil)) pos = Fpoint(); /* default to point */ CHECK_NUMBER_COERCE_MARKER(pos,1); ipos = XFASTINT(pos); /* Generate the list of buttons */ for (buttons = bf1->buttons, b_list = Qnil; !NIL(buttons); buttons = XBUTTON(buttons)->next) { register int first, last; button = XBUTTON(buttons); first = marker_position (button->start); /* button start */ last = marker_position (button->end); /* button end */ if ((first <= ipos) && (ipos < last)) b_list = Fcons (buttons, b_list); } return Fnreverse(b_list); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-list",Fbutton_list,Sbutton_list,0,1,0, "(epoch::zone-list [buffer]) returns a list of all zones in the\n\ current (or specified) buffer.") (buffer) Lisp_Object buffer; { register struct buffer *bf1; register struct Lisp_Button *button; register Lisp_Object buttons,b_list; /* Check for a valid buffer, or if null, use the current buffer */ buffer = NIL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer) ; CHECK_BUFFER(buffer,0); bf1 = XBUFFER(buffer); /* Generate the list of buttons */ for ( buttons = bf1->buttons, b_list = Qnil ; !NIL(buttons) ; buttons = XBUTTON(buttons)->next ) b_list = Fcons(buttons, b_list); return Fnreverse(b_list); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zonep",Fbuttonp,Sbuttonp,1,1,0, "(epoch::zonep OBJECT) returns non nil iff OBJECT is a zone") (button) Lisp_Object button; { return (XTYPE (button) == Lisp_Button) ? Qt : Qnil; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-buffer",Fbutton_buffer,Sbutton_buffer,1,1,0, "Returns the buffer ZONE is in") (button) Lisp_Object button; { struct buffer *b; CHECK_BUTTON (button,0); b = XMARKER(XBUTTON(button)->start)->buffer; if (!b) return Qnil; XSET(button,Lisp_Buffer,b); return button; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-read-only-p",Fbutton_read_only_p,Sbutton_read_only_p, 1,1,0, "Returns t if zone is read-only; else nil.") (button) Lisp_Object button; { CHECK_BUTTON (button,0); return NIL(XBUTTON(button)->read_only) ? Qnil : Qt; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::set-zone-read-only", Fset_button_read_only,Sset_button_read_only,2,2,0, "Set ZONE to have a read-only status of FLAG") (button,flag) Lisp_Object button, flag; { CHECK_BUTTON (button,0); /* If flag is changing, adjust buffer's read-only-button counter */ if (NIL(XBUTTON(button)->read_only) && !NIL(flag)) current_buffer->read_only_buttons++; if (!NIL(XBUTTON(button)->read_only) && NIL(flag)) current_buffer->read_only_buttons--; XBUTTON(button)->read_only = NIL(flag) ? Qnil : Qt; return button; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-transient-p",Fbutton_transient_p,Sbutton_transient_p, 1,1,0, "Returns t if zone has transient flag set; else nil.") (button) Lisp_Object button; { CHECK_BUTTON (button,0); return NIL(XBUTTON(button)->transient) ? Qnil : Qt; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::set-zone-transient", Fset_button_transient,Sset_button_transient,2,2,0, "Set ZONE to have a transient status of FLAG. This is useful if\n\ the zone should be ignored by undo.") (button,flag) Lisp_Object button, flag; { CHECK_BUTTON (button,0); XBUTTON(button)->transient = NIL(flag) ? Qnil : Qt; return button; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-style",Fbutton_style,Sbutton_style,1,1,0, "Returns the zone's style object.") (button) Lisp_Object button; { CHECK_BUTTON (button,0); return (XBUTTON(button)->style); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::set-zone-style", Fset_button_style,Sset_button_style,2,2,0, "Sets ZONE to have STYLE for display.") (button,style) Lisp_Object button, style; { CHECK_BUTTON (button,0); if (NIL(style)) XBUTTON(button)->style = Qnil; else { CHECK_STYLE(style,0); XBUTTON(button)->style = style; } return button; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-start",Fbutton_start,Sbutton_start,1,1,0, "Return position of start of ZONE, or nil if zone not inserted.") (button) Lisp_Object button; { CHECK_BUTTON (button,0); return Fmarker_position(XBUTTON(button)->start); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-end",Fbutton_end,Sbutton_end,1,1,0, "Return position of end of ZONE, or nil if zone not inserted.") (button) Lisp_Object button; { CHECK_BUTTON(button,0); return Fmarker_position(XBUTTON(button)->end); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zone-data",Fbutton_data,Sbutton_data,1,1,0, "Return value of ZONE's data field") (button) Lisp_Object button; { CHECK_BUTTON (button,0); return (XBUTTON(button)->data); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::set-zone-data",Fset_button_data,Sset_button_data,2,2,0, "Set value of zone's data field. returns data.") (button,data) Lisp_Object button,data; { CHECK_BUTTON (button,0); XBUTTON(button)->data = data; return data; } /* ------------------------------------------------------------------------- */ /* Like the elisp primitive, but potentially start at a specified point * in the button list (if called internally */ Lisp_Object raw_buttons_in_region(reg_start,reg_end,start_b,partial,transient) register int reg_start,reg_end; Lisp_Object start_b; int partial,transient; { register Lisp_Object buttons,b_list; buttons = start_b; for ( b_list = Qnil ; !NIL(buttons) ; buttons = XBUTTON(buttons)->next ) { register int start,end; if ((start = marker_position(XBUTTON(buttons)->start)) == (end = marker_position(XBUTTON(buttons)->end))) continue; /* No more relevent buttons in list for this region */ if (reg_end < start) break; if ( transient ) if ( !NIL(Fbutton_transient_p(buttons)) ) continue; if ( partial ) { if ( start >= reg_start && end <= reg_end ) b_list = Fcons(buttons, b_list); } else { if ((start >= reg_start && start <= reg_end) || (end > reg_start && end <= reg_end)) b_list = Fcons(buttons, b_list); } } return Fnreverse(b_list); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::zones-in-region",Fbuttons_in_region,Sbuttons_in_region,2,5,0, "Returns a list of zones contained in the region defined by START\n\ and END. An optional parameter, PARTIAL determines if zones only\n\ partially contained in the region are included. Its default value is NIL.\n\ Another optional parameter, TRANSIENT is T when zones with the\n\ transient field are included. It defaults to NIL. Zero-length zones are\n\ not included in the list. The BUFFER may specified; if not, the current\n\ buffer is used.") (pos1, pos2, partial, transient, buffer) Lisp_Object pos1, pos2, partial, transient, buffer; { struct buffer *bf1; register struct Lisp_Button *button; register Lisp_Object buttons,b_list; register int region_start, region_end; /* Check for a valid buffer, or if null, use the current buffer */ buffer = NIL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer) ; CHECK_BUFFER(buffer,2); bf1 = XBUFFER(buffer); /* Verify the region */ CHECK_NUMBER(pos1,0); CHECK_NUMBER(pos2,1); region_start = XFASTINT(pos1); region_end = XFASTINT(pos2); if (region_start > region_end) /* insure that start <= end */ { int tmp = region_end; region_end = region_start; region_start = tmp; } return raw_buttons_in_region(region_start,region_end,bf1->buttons, NIL(partial),NIL(transient)); } /* ------------------------------------------------------------------------- */ #define NO_REGION_OVERLAP(x1,x2,y1,y2) ( (x2) <= (y1) || (y2) <= (x1) ) Lisp_Object raw_read_only_region(reg_start,reg_end,start_b) register int reg_start,reg_end; Lisp_Object start_b; { Lisp_Object buttons = start_b; register struct Lisp_Button *button; for ( ; !NIL(buttons) ; buttons = button->next) { register int first; button = XBUTTON(buttons); first = marker_position (button->start); /* button start */ if (reg_end < first) break; /* No more possible buttons */ if (!NIL(button->read_only)) { register int last; last = marker_position (button->end); /* button end */ if (! NO_REGION_OVERLAP(reg_start,reg_end,first,last)) { register Lisp_Object buttons2; register struct Lisp_Button *button2; register int first2,last2; /* now check remaining buttons for better candidate(s) */ for (buttons2 = button->next; !NIL(buttons2); buttons2 = button2->next) { button2 = XBUTTON(buttons2); if (!NIL(button2->read_only)) { first2 = marker_position (button2->start); last2 = marker_position (button2->end); /* if next button doesn't overlap * no better candidates exist, so return. */ if (NO_REGION_OVERLAP(reg_start,reg_end,first2,last2)) return (buttons); /* otherwise, this button also overlaps the region, so * test if it is a better solution than the first * one we found. If so, change the outer loop * and test for a better (still) solution. If * not, then continue this inner loop of testing. */ else if (first2 > first) { button = button2; first = first2; last = last2; buttons = buttons2; } } } return (buttons); /* return the better candidate */ } } } return Qnil; /* no read-only buttons in this region */ } /* ------------------------------------------------------------------------- */ /* * read-only-region-p * Follow the display rule for selecting buttons, and given a region * (start and end), return either nil if no read-only buttons overlap the * region, or return the right-most read-only button overlapping the region. */ /* Change to collision detection. We asssume that the regious are open, so * that if they overlap at only the endpoints, then there is no collision. * There's no overlap iff X ends before Y starts, or Y ends before X starts. * This assumes that x1 <= x2 && y1 <= y2. */ DEFUN ("epoch::read-only-region-p", Fread_only_region_p,Sread_only_region_p,2,3,0, "Given the START and END of a region in BUFFER (current buffer if omitted), check that region for read-only zones. START and END do not have to be in right order. If found, return the zone; else return nil.") (mark1,mark2,buffer) Lisp_Object mark1,mark2,buffer; { struct buffer *bf1; register Lisp_Object buttons; register struct Lisp_Button *button; register int start,end; buffer = NIL(buffer) ? Fcurrent_buffer() : Fget_buffer(buffer); CHECK_BUFFER(buffer,2); bf1 = XBUFFER(buffer); CHECK_NUMBER_COERCE_MARKER(mark1,0); CHECK_NUMBER_COERCE_MARKER(mark2,1); start = XFASTINT(mark1); end = XFASTINT(mark2); if (start > end) /* insure that start <= end */ { int tmp = end; end = start; start = tmp; } return raw_read_only_region(start,end,bf1->buttons); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* Return a style; either the buffer-local style of WINDOW's buffer, or * the screen style */ struct Lisp_Style * find_style(w,m) struct window *w; int m; /* 0 = normal; 1 = cursor; 2 = reverse */ { struct buffer *b = XBUFFER(w->buffer); struct Lisp_Style *ret_val; switch (m) { default: case 0: return STYLEP(b->style) ? XSTYLE(b->style) : XSTYLE(XROOT(w->root)->stylenorm); case 2: return XSTYLE(XROOT(w->root)->stylerev); case 1: return XSTYLE(XROOT(w->root)->stylecursor); } } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* given a buffer position, and a window, return a new 'start_button' for * the window. */ Lisp_Object get_start_button(pos,w) int pos; struct window *w; { register struct buffer *b = XBUFFER(w->buffer); register int start; register int end; register Lisp_Object buttons,ret_button; if (NIL(b->buttons)) { /* Window's buffer starting pt unchanged */ return Qnil; } ret_button = buttons = b->buttons; while (!NIL(buttons)) { register struct Lisp_Button *button = XBUTTON(buttons); start = marker_position(button->start); end = marker_position(button->end); ret_button = buttons; if (end > pos) break; /* Consider the next one */ buttons = button->next; } /* Take the previous one */ ret_button = XBUTTON(ret_button)->prev; if (!NIL(ret_button)) { start = marker_position(XBUTTON(ret_button)->start); end = marker_position(XBUTTON(ret_button)->end); } #if 0 if (NIL(ret_button)) fprintf(stderr,"Start button nil for window start %d\n",pos); else fprintf(stderr,"Start button from %d to %d for window start %d\n", start,end,pos); #endif return ret_button; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* given a buffer and a location, figure out the style value * and the start/end of the next button. Buttons are assumed to be disjoint * and ordered by position. If no style applies, return Qnil. */ Lisp_Object get_button(b,loc,b_start,b_end,b_first,b_return) struct buffer *b; register int loc; int *b_start, *b_end; Lisp_Object *b_first; Lisp_Object *b_return; { register struct Lisp_Button *button; register Lisp_Object buttons, next_b = Qnil; register int first = -1,last = -1; struct Lisp_Button *drag_button; Lisp_Object drag_button_value; if (!NIL(Vmotion_style_overrides)) { drag_button_value = XSYMBOL(intern("drag-zone"))->value; drag_button = XBUTTON(BUTTONP(drag_button_value) ? drag_button_value : Qnil); } /* Possible start in list */ if (b_first) next_b = *b_first; if (NIL(next_b)) next_b = b->buttons; /* End of buffer - no more buttons in buffer after loc */ if (b_start) *b_start = ZV; if (b_end) *b_end = -1; /* if (b_first) *b_first = Qnil; */ if (b_return) *b_return = Qnil; for (buttons = next_b; !NIL(buttons); buttons = button->next) { button = XBUTTON (buttons); if (loc < (first = marker_position(button->start))) { next_b = buttons; /* Start for next call */ break; } if (loc < (last = marker_position(button->end))) { register Lisp_Object buttons2; register struct Lisp_Button *button2; register int first2,last2; if (b_start) *b_start = first; if (b_end) *b_end = last; if (b_return) *b_return = buttons; /* if (b_first) *b_first = buttons; */ if (!NIL(Vmotion_style_overrides)) { if (button == drag_button) return button->style; } for (buttons2 = button->next; !NIL(buttons2); buttons2 = button2->next) { button2 = XBUTTON (buttons2); if ((first2 = marker_position(button2->start)) >= last) return button->style; else if (first2 > loc) { if (b_end) *b_end = first2; return button->style; } else if (loc < (last2 = marker_position(button2->end))) { button = button2; first = first2; last = last2; buttons = buttons2; if (b_start) *b_start = first; if (b_end) *b_end = last; if (b_return) *b_return = buttons; } } return button->style; } } /* Provide a hint about the start of the next button in buffer */ if ((b_start) && first >= 0) *b_start = first; return Qnil; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::clear-zones",Fclear_buttons,Sclear_buttons,0,1,"", "Remove all zones in BUFFER (current buffer if nil).") (buffer) Lisp_Object buffer; { if (EQ(buffer,Qnil)) XSET(buffer,Lisp_Buffer,current_buffer); else buffer = Fget_buffer(buffer); if (EQ(buffer,Qnil)) return Qnil; else { extern Lisp_Object find_buffer_start_button_in_window(); register Lisp_Object buttons = XBUFFER(buffer)->buttons; do_windows_of_screens(find_buffer_start_button_in_window,buffer); /* make buttons' markers point nowhere */ if (!NIL (buttons)) { XBUFFER(buffer)->force_redisplay = Qt; windows_or_buffers_changed++; } while (!NIL (buttons)) { register struct Lisp_Button *button = XBUTTON(buttons); /* avoid overhead of calling Fset_marker */ unchain_marker(button->start); unchain_marker(button->end); button->prev = Qnil; buttons = button->next; button->next = Qnil; } XBUFFER(buffer)->buttons = Qnil; XBUFFER(buffer)->read_only_buttons = 0; return Qt; } } /* ------------------------------------------------------------------------ */ VOID RemoveButtonFromBuffer(b,bf,unchain) struct Lisp_Button *b; struct buffer *bf; int unchain; /* unchain markers? */ { /* verify that we can remove the button */ extern Lisp_Object find_buffer_start_button_in_window(); register Lisp_Object buffer; XSET(buffer,Lisp_Buffer,bf); CHECK_READ_ONLY(bf,buffer); if (!NIL (b->next)) XBUTTON(b->next)->prev = b->prev; if (NIL (b->prev)) bf->buttons = b->next; else XBUTTON(b->prev)->next = b->next; b->next = b->prev = Qnil; do_windows_of_screens(find_buffer_start_button_in_window,buffer); if (unchain) { unchain_marker(b->start); unchain_marker(b->end); } /* Decrement counter if deleting a read-only-button */ if (!NIL(b->read_only)) bf->read_only_buttons--; bf->force_redisplay = Qt; windows_or_buffers_changed++; MODIFY_BUFFER(bf); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::move-zone",Fmove_button,Smove_button,1,4,0, "Moves the ZONE to cover the desired region from START to END in BUFFER.\n\ START and END do not have to be in the right order.\n\ If START or END is nil, the current location is used.\n\ If BUFFER is nil, the zone buffer is used, or if that is not set, the\n\ current buffer. The zone is removed from its current buffer and\n\ inserted into the new buffer.") (button,pos1,pos2,buffer) Lisp_Object button,pos1,pos2,buffer; { register struct Lisp_Button *b,*prevb,*nextb; register struct buffer *sbuff,*dbuff; /* destination and source buffers */ int first=0,last=0; Lisp_Object blist; CHECK_BUTTON (button,0); b = XBUTTON(button); /* extract the locations from the markers */ if (!NIL(pos1)) { CHECK_NUMBER_COERCE_MARKER(pos1,1); first = XFASTINT(pos1); } else if (XMARKER(b->start)->buffer) /* it's already pointing somewhere */ first = marker_position(b->start); if (!NIL(pos2)) { CHECK_NUMBER_COERCE_MARKER(pos2,2); last = XFASTINT(pos2); } else if (XMARKER(b->end)->buffer) /* end marker points somewhere */ last = marker_position(b->end); /* keep ordering intact */ if (first > last) { int tmp; tmp = first; first = last; last = tmp; } /* deal with the buffer. The rules are: * 1. If buffer is set, that's the buffer the button goes in * 2. If buffer is nil, then keep the button in the same buffer * 3. If the buffer and button buffer are nil, use the current buffer */ sbuff = XMARKER(b->start)->buffer; /* source buffer */ if (NIL(buffer)) if (sbuff) /* is there a buffer to stay in? */ { dbuff = sbuff; /* should be in the if, but it's confusing */ XSET(buffer,Lisp_Buffer,dbuff); } else /* no, have to switch */ { buffer = Fcurrent_buffer(); dbuff = XBUFFER(buffer); } else /* buffer was set to something */ { buffer = Fget_buffer(buffer); /* convert possible string, check arg */ if (NIL(buffer)) error("Invalid buffer for button move"); dbuff = XBUFFER(buffer); } /* make sure the destination is alive */ if (NIL (dbuff->name)) return Qnil; /* bad destination - return nil */ /* check the case that the button isn't going anywhere */ if ( sbuff == dbuff && marker_position(b->start) == first && marker_position(b->end) == last ) return button; /* just return it */ /* make sure we can put the button in the new buffer */ CHECK_READ_ONLY(dbuff,buffer); /* remove button from old buffer */ if (sbuff) RemoveButtonFromBuffer(b,sbuff,0); /* don't unchain */ /* set the button to have to right marker locations * Fset_marker takes care of unchaining from old buffer, etc. */ Fset_marker(b->start,first,buffer); Fset_marker(b->end,last,buffer); /* search the list for a place to insert. A valid place is either where the * next button starts _after_ this one, or the end of the list. */ prevb = 0; /* no previous to start with */ for ( blist = dbuff->buttons ; !NIL(blist) ; blist = XBUTTON(blist)->next ) { nextb = XBUTTON(blist); if (marker_position(nextb->start) > first) { /* insert before this button */ b->next = blist; b->prev = nextb->prev; nextb->prev = button; if (prevb) /* there's a previous button */ prevb->next = button; else dbuff->buttons = button; break; /* get out of for loop */ } prevb = nextb; } if (NIL(blist)) /* didn't find an insertion point */ { if (!prevb) /* no buttons in buffer */ dbuff->buttons = button; /* that's it */ else /* put at end of list */ { prevb->next = button; XSET(b->prev,Lisp_Button,prevb); } } /* Adjust buffer(s) read-only button counts */ if (!NIL(b->read_only) && sbuff) { sbuff->read_only_buttons--; dbuff->read_only_buttons++; } /* mark buffer(s) as needing redisplay */ if (sbuff) sbuff->force_redisplay = Qt; dbuff->force_redisplay = Qt; windows_or_buffers_changed++; return button; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::zone-at",Fbutton_at,Sbutton_at,0,2,0, "(epoch::zone-at POS [BUFFER]) Return the zone, if any, containing POS.") (pos,buffer) Lisp_Object pos,buffer; { int first,last,ipos; struct Lisp_Style *style; Lisp_Object button = Qnil,ob; if (EQ(buffer,Qnil)) XSET(buffer,Lisp_Buffer,current_buffer); else buffer = Fget_buffer(buffer); if (EQ(buffer,Qnil)) return Qnil; if (EQ(pos,Qnil)) pos = Fpoint(); /* default to point */ CHECK_NUMBER_COERCE_MARKER(pos,1); ipos = XFASTINT(pos); ob = get_button(XBUFFER(buffer),ipos,&first,&last,0,&button); style = XSTYLE(ob); return (ipos >= first && ipos < last) ? button : Qnil; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::delete-zone",Fdelete_button,Sdelete_button,1,1,0, "(epoch::delete-zone ZONE) remove ZONE from the buffer it is in (if any).\n\ if argument is nil, do nothing.") (button) Lisp_Object button; { register struct buffer *bf; register struct Lisp_Button *b; if (NIL(button)) return Qnil; CHECK_BUTTON (button,0); b = XBUTTON(button); bf = XMARKER(b->start)->buffer; if (!bf) return button; RemoveButtonFromBuffer(b,bf,1); /* remove and unchain markers */ return button; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::delete-zone-at",Fdelete_button_at,Sdelete_button_at,0,2,0, "Delete the zone, if any, containing POSITION in BUFFER.") (pos,buffer) Lisp_Object pos,buffer; { return Fdelete_button(Fbutton_at(pos,buffer)); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::get-color",Fepoch_get_color,Sepoch_get_color,1,1,0, "Convert the name of a color into a X-cardinal resource (a pixel value)") (name) Lisp_Object name; { Lisp_Object zreturn = Qnil; int ok = 1; /* valid input flag */ XColor c; Colormap cmap; BLOCK_INPUT_DECLARE(); cmap = DefaultColormap(XD_display,DefaultScreen(XD_display)); switch XTYPE(name) { case Lisp_Vector : if (XVECTOR(name)->size >= 3) { c.red = XVECTOR(name)->contents[0]; c.green = XVECTOR(name)->contents[1]; c.blue = XVECTOR(name)->contents[2]; } else ok = 0; break; case Lisp_String : HOLD_INPUT(ok = XParseColor(XD_display,cmap,XSTRING(name)->data,&c)) break; case Lisp_Xresource : if (XXRESOURCE(name)->type == XA_CARDINAL) return name; /* else fall through */ default : error("Color must be string, vector, or X-cardinal"); break; } if (ok) { BLOCK_INPUT(); c.flags = DoRed + DoGreen + DoBlue; if (XAllocColor(XD_display,cmap,&c)) zreturn = make_Xresource(XD_display,XD_plane,c.pixel,XA_CARDINAL); UNBLOCK_INPUT(); } return zreturn; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::get-color-rw",Fepoch_get_color_rw,Sepoch_get_color_rw,0,0,0, "Allocates a read-write colorcell for NAME.\n\ Similar to epoch::get-color.\n\ Returns nil if a cell cannot be allocated or vector has wrong size,\n\ otherwise returns X-cardinal for the read-write colorcell.\n\ Expects NAME to be a string, vector of length >=3, or X-cardinal.") () { Lisp_Object zreturn = Qnil; XColor c; Colormap cmap; unsigned long plane_masks[1]; unsigned long pix_val[1]; BLOCK_INPUT_DECLARE(); cmap = DefaultColormap(XD_display,DefaultScreen(XD_display)); BLOCK_INPUT(); c.flags = DoRed + DoGreen + DoBlue; if (XAllocColorCells(XD_display,cmap, /*contig*/ False, /*plane mask*/ plane_masks, /*num planes*/ 0, /*pixels*/ pix_val, /*num colors*/ 1)) zreturn = make_Xresource(XD_display,XD_plane,pix_val[0],XA_CARDINAL); UNBLOCK_INPUT(); return zreturn; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::set-color-rw",Fepoch_set_color_rw,Sepoch_set_color_rw,2,2,0, "Set read-write color cell CELL to NAME\n\ Use epoch::get-color-rw to allocate a color cell.\n\ CELL must be a X-cardinal value, NAME can be a string, vector or color name") (cell,name) Lisp_Object cell,name; { Lisp_Object zreturn = Qnil; int ok = 1; /* valid input flag */ XColor c; Colormap cmap; BLOCK_INPUT_DECLARE(); cmap = DefaultColormap(XD_display,DefaultScreen(XD_display)); if (!XRESOURCEP(cell) || (XXRESOURCE(cell)->type != XA_CARDINAL)) error("Cell must be X-Cardinal."); switch XTYPE(name) { case Lisp_Vector : if (XVECTOR(name)->size >= 3) { c.red = XVECTOR(name)->contents[0]; c.green = XVECTOR(name)->contents[1]; c.blue = XVECTOR(name)->contents[2]; c.pixel = XXRESOURCE(cell)->id; } else ok = 0; break; case Lisp_String : HOLD_INPUT(ok = XParseColor(XD_display,cmap,XSTRING(name)->data,&c)); c.pixel = XXRESOURCE(cell)->id; break; default : error("Name must be string, vector"); break; } /* if ok!=0 then c has the color that we want to put into the rw cell */ if (ok) { BLOCK_INPUT(); c.flags = DoRed + DoGreen + DoBlue; if (XStoreColor(XD_display,cmap,&c)) zreturn = Qt; UNBLOCK_INPUT(); } return zreturn; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::free-color", Fepoch_free_color, Sepoch_free_color, 1, 1, 0, "Release COLOR in the X server for reuse.") (color) Lisp_Object color; { if (XRESOURCEP(color) && XXRESOURCE(color)->type == XA_CARDINAL) XFreeColors(XD_display, DefaultColormap(XD_display,XD_plane), &(XXRESOURCE(color)->id), 1, 0); else error("Color freed must be an X-cardinal"); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ DEFUN ("epoch::number-of-colors",Fx_number_of_colors,Sx_number_of_colors,0,0,0, "Returns the number of colors available (display cells). Monochrome returns 2, grey scale and color return larger numbers.") () { return make_number(DisplayCells(cur_Xscreen->display,cur_Xscreen->plane)); } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::stylep",Fstylep,Sstylep,1,1,0, "(epoch::stylep OBJECT) returns non nil iff OBJECT is a style") (style) Lisp_Object style; { return (XTYPE (style) == Lisp_Style) ? Qt : Qnil; } /* ------------------------------------------------------------------------- */ DEFUN ("epoch::make-style",Fepoch_make_style,Sepoch_make_style,0,0,0, "Creates a style object, without no values set.\n\ A style is used to describe how to plot characters. Current fields are\n\ foreground : foreground color for text\n\ background : background color for text\n\ cursor-foreground : foreground for plotting the cursor\n\ cursor-background : background for plotting the cursor\n\ font : font to use for characters\n\ underline : color to draw underline in\n\ stipple : stipple for normal text\n\ background-stipple : stipple for character backgrounds\n\ cursor-stipple : stipple for the cursor background") () { Lisp_Object val; val = Fmake_vector (make_number((sizeof (struct Lisp_Style) - sizeof (struct Lisp_Vector) + sizeof (Lisp_Object)) / sizeof (Lisp_Object)), Qnil); XSETTYPE (val, Lisp_Style); return val; } /* ------------------------------------------------------------------------- */ Lisp_Object QXcardinalp,QXfontp,QXbitmapp; #ifdef HAVE_GRAPHIC_ZONES Lisp_Object QXpixmapp; #endif #define STYLE_SET_FUNCTION(field,conversion) \ (style,value) Lisp_Object style,value;\ {\ CHECK_STYLE(style,0);\ XSTYLE(style)->field = EQ(Qnil,value) ? value : conversion(value);\ return style;\ } #define STYLE_GET_FUNCTION(field) \ (style) Lisp_Object style;\ { CHECK_STYLE(style,0); return XSTYLE(style)->field; } /* ---------- */ DEFUN ("epoch::set-style-foreground", Fepoch_set_style_foreground, Sepoch_set_style_foreground, 2,2,0, "Set the STYLE foreground to COLOR") STYLE_SET_FUNCTION(foreground,Fepoch_get_color); DEFUN ("epoch::style-foreground", Fepoch_style_foreground, Sepoch_style_foreground, 1,1,0, "Return the STYLE's current foreground color") STYLE_GET_FUNCTION(foreground); /* ---------- */ DEFUN ("epoch::set-style-background", Fepoch_set_style_background, Sepoch_set_style_background, 2,2,0, "Set the STYLE background to COLOR") STYLE_SET_FUNCTION(background,Fepoch_get_color); DEFUN ("epoch::style-background", Fepoch_style_background, Sepoch_style_background, 1,1,0, "Return the STYLE's current background color") STYLE_GET_FUNCTION(background); /* ---------- */ DEFUN ("epoch::set-style-cursor-foreground", Fepoch_set_style_cursor_foreground, Sepoch_set_style_cursor_foreground, 2,2,0, "Set the STYLE cursor foreground to COLOR") STYLE_SET_FUNCTION(cursor_foreground,Fepoch_get_color); DEFUN ("epoch::style-cursor-foreground", Fepoch_style_cursor_foreground, Sepoch_style_cursor_foreground, 1,1,0, "Return the STYLE's current cursor foreground color") STYLE_GET_FUNCTION(cursor_foreground); /* ---------- */ DEFUN ("epoch::set-style-cursor-background", Fepoch_set_style_cursor_background, Sepoch_set_style_cursor_background, 2,2,0, "Set the STYLE cursor background to COLOR") STYLE_SET_FUNCTION(cursor_background,Fepoch_get_color); DEFUN ("epoch::style-cursor-background", Fepoch_style_cursor_background, Sepoch_style_cursor_background, 1,1,0, "Return the STYLE's current cursor background color") STYLE_GET_FUNCTION(cursor_background); /* ---------- */ DEFUN ("epoch::set-style-underline", Fepoch_set_style_underline, Sepoch_set_style_underline, 2,2,0, "Set the STYLE underline to COLOR") STYLE_SET_FUNCTION(underline,Fepoch_get_color); DEFUN ("epoch::style-underline", Fepoch_style_underline, Sepoch_style_underline, 1, 1, 0, "Return the STYLE's current underline color") STYLE_GET_FUNCTION(underline); /* ---------- */ DEFUN ("epoch::set-style-font", Fepoch_set_style_font, Sepoch_set_style_font, 2, 2, 0, "Set the STYLE to FONT") STYLE_SET_FUNCTION(font,get_style_font); DEFUN ("epoch::style-font", Fepoch_style_font, Sepoch_style_font, 1, 1, 0, "Return the current font for STYLE") STYLE_GET_FUNCTION(font); /* ---------- */ /* Yow. Stipples are different - no conversion function available */ #undef STYLE_SET_FUNCTION #define STYLE_SET_FUNCTION(field,rtype,predicate) \ (style,value) Lisp_Object style,value;\ { \ if (! \ ( EQ(value,Qnil) \ || (XRESOURCEP(value) && XXRESOURCE(value)->type == rtype))) \ return style;\ XSTYLE(style)->field = value; \ return style; \ } /* ---------- */ DEFUN ("epoch::set-style-stipple", Fepoch_set_style_stipple, Sepoch_set_style_stipple, 2, 2, 0, "Set the STYLE to have STIPPLE") STYLE_SET_FUNCTION(stipple,XA_BITMAP,QXbitmapp); DEFUN ("epoch::style-stipple", Fepoch_style_stipple, Sepoch_style_stipple, 1, 1, 0, "Return the current stipple bitmap for STYLE") STYLE_GET_FUNCTION(stipple); /* ---------- */ DEFUN ("epoch::set-style-cursor-stipple", Fepoch_set_style_cursor_stipple, Sepoch_set_style_cursor_stipple, 2, 2, 0, "Set the STYLE to have a cursor STIPPLE") STYLE_SET_FUNCTION(cursor_stipple,XA_BITMAP,QXbitmapp); DEFUN ("epoch::style-cursor-stipple", Fepoch_style_cursor_stipple, Sepoch_style_cursor_stipple, 1, 1, 0, "Return the current cursor stipple bitmap for STYLE") STYLE_GET_FUNCTION(cursor_stipple); /* ---------- */ DEFUN ("epoch::set-style-background-stipple", Fepoch_set_style_background_stipple, Sepoch_set_style_background_stipple, 2, 2, 0, "Set the STYLE to have a background STIPPLE") STYLE_SET_FUNCTION(background_stipple,XA_BITMAP,QXbitmapp); DEFUN ("epoch::style-background-stipple", Fepoch_style_background_stipple, Sepoch_style_background_stipple, 1, 1, 0, "Return the current background stipple bitmap for STYLE") STYLE_GET_FUNCTION(background_stipple); /* ---------- */ #ifdef HAVE_GRAPHIC_ZONES DEFUN ("epoch::set-style-pixmap",Fepoch_set_style_pixmap,Sepoch_set_style_pixmap, 2, 2, 0, "Set the STYLE to have a PIXMAP for display with an opaque font.") STYLE_SET_FUNCTION(pixmap,XA_PIXMAP,QXpixmapp); DEFUN ("epoch::style-pixmap",Fepoch_style_pixmap,Sepoch_style_pixmap, 1, 1, 0, "Return the current pixmap for STYLE") STYLE_GET_FUNCTION(pixmap); #endif /* HAVE_GRAPHIC_ZONES */ /* ---------- */ #undef STYLE_SET_FUNCTION #undef STYLE_GET_FUNCTION DEFUN ("epoch::set-style-tag",Fepoch_set_style_tag,Sepoch_set_style_tag,2,2,0, "Set the STYLE to have TAG as an identifier.") (style,tag) Lisp_Object style,tag; { CHECK_STYLE(style,0); XSTYLE(style)->tag = tag; return tag; } DEFUN ("epoch::style-tag",Fepoch_style_tag,Sepoch_style_tag,1,1,0, "Return the current tag value for STYLE") (style) Lisp_Object style; { CHECK_STYLE(style,0); return XSTYLE(style)->tag; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ Lisp_Object get_style_font(name) Lisp_Object name; { struct X_font *f; Lisp_Object font; BLOCK_INPUT_DECLARE(); if (XRESOURCEP(name) && XXRESOURCE(name)->type == XA_FONT) { f = find_font(XXRESOURCE(name)->id); XSET(font,Lisp_Raw_Data,f); return font; } CHECK_STRING(name,0); f = load_font(XSTRING(name)->data); if (f) XSET(font,Lisp_Raw_Data,f); else font = Qnil; return font; } /* ------------------------------------------------------------------------- */ /* Some ugliness here, in order to do stippling. * In order to stipple, we need two GC's. We can't use XDrawImageString since * it ignores stipples. Instead, we have to XFillRectangle with the background * color first, and then XDrawString. The problem is that XFillRectangle uses * the foreground color, so the GC we use for that must be the inverse of the * one for the text. So, we'll set the gc_style GC up, and then exchange * foreground/background and the mask bits, and change gc_inverse to be * correct. Sadly, this means that GCofStyle is in effect passing results back * in global variables (gc_inverse), but that's life. Note that if the * attribute is 0, then none of this goes on, since default text can't be * stippled. */ GC GCofStyle(type,s,w) int type; /* type - text, cursor, etc. */ struct Lisp_Style *s; /* Style */ struct window *w; /* Window */ { struct Root_Block *rb = XROOT(w->root); /* Screen for this window*/ Lisp_Object scratch; XGCValues gcv; unsigned long gcmask = 0, tmp; struct buffer *b = XBUFFER(w->buffer); GC ret_GC; XRectangle rect; XS_DEF; /* Pick up essential fields from appropriate default - either the * buffer-local, or a screen-local style. NOTE: even if buffer-local * style exists, fields aren't guaranteed to be valid. If 'style' * contains a value, supercede the default. */ switch (type) { default: case 0: /* Text */ ret_GC = xs->gc_norm; gcv.foreground = XRESOURCEP(s->foreground) ? XXRESOURCE(s->foreground)->id : XXRESOURCE(STYLE_FIELD(w,foreground,stylenorm))->id; gcv.background = XRESOURCEP(s->background) ? XXRESOURCE(s->background)->id : XXRESOURCE(STYLE_FIELD(w,background,stylenorm))->id; gcv.font = XFID(XXFONT(STYLE_FIELD(w,font,stylenorm))); gcv.fill_style = FillSolid; break; case 3: /* Active Cursor Outline */ ret_GC = xs->gc_curs; gcv.foreground = XRESOURCEP(s->cursor_background) ? XXRESOURCE(s->cursor_background)->id : XXRESOURCE(STYLE_FIELD(w,cursor_background,stylecursor))->id; gcv.background = XRESOURCEP(s->cursor_foreground) ? XXRESOURCE(s->cursor_foreground)->id : XXRESOURCE(STYLE_FIELD(w,cursor_foreground,stylecursor))->id; gcv.fill_style = FillSolid; break; case 1: /* Cursor */ ret_GC = xs->gc_curs; gcv.foreground = XRESOURCEP(s->cursor_foreground) ? XXRESOURCE(s->cursor_foreground)->id : XXRESOURCE(STYLE_FIELD(w,cursor_foreground,stylecursor))->id; gcv.background = XRESOURCEP(s->cursor_background) ? XXRESOURCE(s->cursor_background)->id : XXRESOURCE(STYLE_FIELD(w,cursor_background,stylecursor))->id; gcv.font = XFID(XXFONT(STYLE_FIELD(w,font,stylenorm))); gcv.fill_style = FillSolid; break; case 2: /* Reverse */ ret_GC = xs->gc_rev; gcv.foreground = XRESOURCEP(s->foreground) ? XXRESOURCE(s->foreground)->id : XXRESOURCE(STYLE_FIELD(w,background,stylerev))->id; gcv.background = XRESOURCEP(s->background) ? XXRESOURCE(s->background)->id : XXRESOURCE(STYLE_FIELD(w,foreground,stylerev))->id; gcv.font = XFID(XXFONT(STYLE_FIELD(w,font,stylenorm))); gcv.fill_style = FillSolid; break; } #ifdef HAVE_GRAPHIC_ZONES if ((XTYPE(s->font) == Lisp_Raw_Data) && !XXFONT(s->font)->virtual) { gcv.font = XFID(XXFONT(s->font)); } #else if (XTYPE(s->font) == Lisp_Raw_Data) { gcv.font = XFID(XXFONT(s->font)); } #endif gcmask = GCForeground + GCBackground + GCFillStyle + GCFont; if (XRESOURCEP(s->stipple)) gcmask |= GCStipple + GCFillStyle, gcv.stipple = XXRESOURCE(s->stipple)->id, gcv.fill_style = FillStippled; XChangeGC(xs->display,ret_GC,gcmask,&gcv); /* Set GC's clipping rectangle to be this window's dimensions */ rect.x = 0; rect.y = 0; rect.width = (short) XFASTINT(w->pixwidth); rect.height = (short) XFASTINT(w->pixheight); XSetClipRectangles(xs->display,ret_GC, XFASTINT(w->pixleft), XFASTINT(w->pixtop), &rect,1,Unsorted); if (type == 3) return ret_GC; /* set up the background character box, if there's a style */ if (s) { /* Have to play games to get the stippling right. Most of these options * are set for stippling, but get changed if there is no stipple */ gcmask = GCForeground + GCBackground + GCFillStyle + GCStipple; gcv.fill_style = FillOpaqueStippled; gcv.foreground = XXRESOURCE(STYLE_FIELD(w,background,stylenorm))->id; /* if there's a cursor stipple, and we're doing a cursor, use that * else if not a cursor and a background stipple, use that * else use a solid pattern, no stipple */ if (type == 1 && XRESOURCEP(s->cursor_stipple)) gcv.stipple = XXRESOURCE(s->cursor_stipple)->id; else if (type != 1 && XRESOURCEP(s->background_stipple)) gcv.stipple = XXRESOURCE(s->background_stipple)->id; else { gcv.fill_style = FillSolid; gcmask &= ~(GCStipple + GCBackground); gcv.foreground = gcv.background; } XChangeGC(xs->display, xs->gc_inverse, gcmask, &gcv); } return ret_GC; } int DEBUG_ALL = 0; /* ------------------------------------------------------------------------- */ ShipOutTextBlock(str,count,x,y,a,d,cursor,style,w) char *str; /* chars to write */ int count; /* # chars to write */ int x,y; /* x, y (baseline) pixel pos */ int a,d; /* Ascent for whole line */ int cursor; struct Lisp_Style *style; /* Style for display purposes */ struct window *w; { struct Root_Block *rb = XROOT(w->root); XS_DEF; GC theGC; struct Lisp_Style *s; struct X_font *font; struct buffer *b = XBUFFER(w->buffer); XGCValues gcv; unsigned long gcmask; short wid; if (count < 1) return; /* allow calling with 0 counts */ if (DEBUG_ALL) { str[count] = 0; if (rb == cur_root) fprintf(stderr,"Block is %s\n",str); } s = style ? style : find_style(w,cursor); font = XXFONT(STYLE_FIELD(w,font,stylenorm)); if (XTYPE(s->font) == Lisp_Raw_Data) font = XXFONT(s->font); /* Clip against window dimensions for text backing */ wid = min(text_width(font,str,count), (XFASTINT(w->pixleft) + XFASTINT(w->pixwidth) - x)); #ifdef HAVE_GRAPHIC_ZONES if (font->virtual && XRESOURCEP(s->pixmap)) { int i; Bool graphic_expose = False; XSetGraphicsExposures(xs->display,xs->gc_norm, graphic_expose); /* We have a graphical button */ XClearArea(xs->display,xs->xid,x,y-a,wid,a+d,0); for (i = 0; i < count; i++) XCopyArea(xs->display, XXRESOURCE(s->pixmap)->id, /* Source of pixmap */ xs->xid, xs->gc_norm, 0,0, /* Source coords */ XFWIDTH(font), /* Opaque Font dimensions */ XFHEIGHT(font), x + (i * XFWIDTH(font)), y - XFASCENT(font) /* Screen coords */ ); graphic_expose = True; /* Restore the GC to previous value */ XSetGraphicsExposures(xs->display, xs->gc_norm, graphic_expose); if (cursor) { theGC = GCofStyle(3,s,w); XDrawRectangle(xs->display,xs->xid,theGC, x, y-XFASCENT(font), XFWIDTH(font) - 1, XFHEIGHT(font) - 1); } return; } #endif theGC = GCofStyle(cursor,s,w); XFillRectangle(xs->display,xs->xid,xs->gc_inverse,x,y-a,wid,a+d); XDrawString(xs->display,xs->xid,theGC,x,y,str,count); if (XRESOURCEP(s->underline)) { int uy = (y + d - 1); /* Position for underline */ gcv.foreground = XXRESOURCE(s->underline)->id; gcv.line_style = LineSolid; gcv.line_width = 0; gcv.fill_style = FillSolid; gcmask = GCForeground + GCLineStyle + GCLineWidth + GCFillStyle; XChangeGC(xs->display,theGC,gcmask,&gcv); XDrawLine(xs->display,xs->xid,theGC,x,uy,x + wid - 1,uy); } } /* ------------------------------------------------------------------------- */ /* Plot a line L (or portion of line from START to END) of text in window W. * START and END are considered, if non-zero */ PlotTextLine(w,l,start,end,clear) struct window *w; struct line_header *l; struct char_block *start; struct char_block *end; char clear; { struct Root_Block *rb = XROOT(w->root); XS_DEF; WS_DEF; char buf[1000]; /* Buffer for constructing string. */ char *pos; /* Position in buf */ struct char_block *cb; /* Current char in line */ struct Lisp_Style *s,t; /* Current style for plotting */ int cursor; /* flag for ShipOutTextBlock */ int n = 0; /* char count for current region */ int xpos; /* left pixel position of a block */ BLOCK_INPUT_DECLARE (); if (l == 0 || l->ypos == 0) abort(); pos = buf; cb = start ? start : l->body; while (cb != l->body && cb->prev->ch == ' ') cb = cb->prev; xpos = cb->xpos; s = cb->style; cursor = 2 * (l->modeline); BLOCK_INPUT(); while (cb && cb != l->end) { if (cb->style == s && n < 999) { *pos++ = cb->ch; /* Update attributes */ cb->changed = cb->new = 0; n++; if (cb == end) break; cb = cb->next; } else { /* Time to ship out a block */ ShipOutTextBlock(buf,n,xpos,l->ypos,l->ascent,l->descent, cursor,s,w); s = cb->style; xpos = cb->xpos; n = 0; pos = buf; } } /* Ship out dangling stuff */ if (n) ShipOutTextBlock(buf,n,xpos,l->ypos,l->ascent,l->descent, cursor,s,w); if (clear && (l->lwidth < (w->pixleft + w->pixwidth -1)) && (l->ascent + l->descent > 0)) { if (xs->highlight) XFillRectangle(xs->display,xs->xid,xs->gc_norm, l->end->xpos,(l->ypos - l->ascent), (w->pixleft + w->pixwidth - l->lwidth), (l->ascent + l->descent)); else XClearArea(xs->display,xs->xid, l->end->xpos,(l->ypos - l->ascent), (w->pixleft + w->pixwidth - l->lwidth), (l->ascent + l->descent),0); } UNBLOCK_INPUT(); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* Fast insert for char in middle of line. * ASSUMPTIONS: Remaining chars on line will be blt'ed. No region needs * to be cleared at end of line. */ InsertChar(w,l,new,cb,end,clear) struct window *w; struct line_header *l; struct char_block *new,*cb,*end; char clear; { struct Root_Block *rb = XROOT(w->root); XS_DEF; WS_DEF; BLOCK_INPUT_DECLARE(); char b[2]; b[1] = 0; b[0] = new->ch; BLOCK_INPUT(); XCopyArea(xs->display,xs->xid,xs->xid,xs->gc_norm, new->xpos, /* start x */ l->ypos - l->ascent, /* start y */ end->xpos - cb->xpos, /* width */ l->ascent + l->descent, /* height */ cb->xpos, l->ypos - l->ascent); ShipOutTextBlock(b,1,new->xpos,l->ypos,l->ascent,l->descent,0, new->style,w); UNBLOCK_INPUT(); return; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ Lisp_Object Qbuttonp,Qstylep; void syms_of_button() { Qbuttonp = intern ("zonep"); staticpro(&Qbuttonp); Qstylep = intern ("stylep"); staticpro(&Qstylep); QXcardinalp = intern ( "Xcardinalp" ); staticpro(&QXcardinalp); QXfontp = intern ( "Xfontp" ); staticpro(&QXfontp); QXbitmapp = intern ( "Xbitmapp" ); staticpro(&QXbitmapp); #ifdef HAVE_GRAPHIC_ZONES QXpixmapp = intern ("Xpixmapp" ); staticpro(&QXpixmapp); #endif defsubr(&Smake_button); defsubr(&Sbuttonp); defsubr(&Smove_button); defsubr(&Sdelete_button); defsubr(&Sbuttons_at); defsubr(&Sbutton_list); defsubr(&Sread_only_region_p); defsubr(&Sbuttons_in_region); defsubr(&Sbutton_buffer); defsubr(&Sbutton_style); defsubr(&Sset_button_style); defsubr(&Sbutton_start); defsubr(&Sbutton_end); defsubr(&Sbutton_data); defsubr(&Sset_button_data); defsubr(&Sbutton_read_only_p); defsubr(&Sset_button_read_only); defsubr(&Sbutton_transient_p); defsubr(&Sset_button_transient); defsubr(&Sclear_buttons); defsubr(&Sbutton_at); defsubr(&Sdelete_button_at); defsubr(&Sepoch_get_color); defsubr(&Sepoch_get_color_rw); defsubr(&Sepoch_set_color_rw); defsubr(&Sepoch_free_color); defsubr(&Sx_number_of_colors); defsubr(&Sstylep); defsubr(&Sepoch_make_style); defsubr(&Sepoch_set_style_foreground); defsubr(&Sepoch_style_foreground); defsubr(&Sepoch_set_style_background); defsubr(&Sepoch_style_background); defsubr(&Sepoch_style_cursor_foreground); defsubr(&Sepoch_set_style_cursor_foreground); defsubr(&Sepoch_set_style_cursor_background); defsubr(&Sepoch_style_cursor_background); defsubr(&Sepoch_set_style_underline); defsubr(&Sepoch_style_underline); defsubr(&Sepoch_set_style_font); defsubr(&Sepoch_style_font); defsubr(&Sepoch_set_style_stipple); defsubr(&Sepoch_style_stipple); defsubr(&Sepoch_set_style_cursor_stipple); defsubr(&Sepoch_style_cursor_stipple); defsubr(&Sepoch_set_style_background_stipple); defsubr(&Sepoch_style_background_stipple); defsubr(&Sepoch_set_style_tag); defsubr(&Sepoch_style_tag); #ifdef HAVE_GRAPHIC_ZONES defsubr(&Sdefine_opaque_font); defsubr(&Sread_pixmap_file); defsubr(&Squery_pixmap); defsubr(&Sepoch_set_style_pixmap); defsubr(&Sepoch_style_pixmap); #endif DEFVAR_LISP("epoch::zones-modify-buffer",&Vbuttons_modify_buffer, "Flag on whether zones should mark a buffer as modified."); Vbuttons_modify_buffer = Qt; DEFVAR_LISP("epoch::motion-style-overrides",&Vmotion_style_overrides, "*Flag on whether motion style overrides other styles."); Vmotion_style_overrides = Qt; }