Index: lisp/gutter-items.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/lisp/Attic/gutter-items.el,v retrieving revision 1.1.2.15 diff -u -r1.1.2.15 gutter-items.el --- lisp/gutter-items.el 1999/08/31 17:38:20 1.1.2.15 +++ lisp/gutter-items.el 1999/09/07 14:19:43 @@ -284,9 +287,6 @@ Do not modify this directly--use the `progress' or `display-progress'/`clear-progress' functions.") -(defvar progress-area-buffer (get-buffer-create " *Gutter Area*") - "A buffer for the gutter area.") - (defvar progress-glyph-height 32 "Height of the gutter area for progress messages.") @@ -301,31 +301,44 @@ (keyboard-quit)) ;; private variables -(defvar progress-glyph +(defvar progress-gauge-glyph (make-glyph (vector 'progress-gauge :pixel-height (- progress-glyph-height 8) :pixel-width 200 :descriptor "Progress"))) +(defvar progress-text-glyph + (make-glyph [string :data ""])) + (defvar progress-layout-glyph (make-glyph - (vector 'layout - :pixel-height progress-glyph-height - :orientation 'horizontal - :items - (list progress-glyph - (make-glyph - (vector 'button - :pixel-height (- progress-glyph-height 8) - :descriptor " Stop " - :callback '(funcall progress-stop-callback))))))) + (vector 'layout + :orientation 'vertical + :justify 'left + :items + (list progress-text-glyph + (make-glyph + (vector + 'layout + :pixel-height progress-glyph-height + :orientation 'horizontal + :items + (list progress-gauge-glyph + (make-glyph + (vector + 'button + :pixel-height (- progress-glyph-height 8) + :descriptor " Stop " + :callback '(funcall progress-stop-callback)))))))))) +(defvar progress-text-and-extent nil) + (defun progress-displayed-p (&optional return-string frame) "Return a non-nil value if a progress gauge is presently displayed in the gutter area. If optional argument RETURN-STRING is non-nil, return a string containing the message, otherwise just return t." - (let ((buffer (get-buffer " *Gutter Area*"))) + (let ((buffer (get-buffer-create " *Gutter Area*"))) (and (< (point-min buffer) (point-max buffer)) (if return-string (buffer-substring nil nil buffer) @@ -348,7 +361,7 @@ (let ((inhibit-read-only t) (zmacs-region-stays zmacs-region-stays)) ; preserve from change (erase-buffer " *Echo Area*") - (erase-buffer " *Gutter Area*")) + (erase-buffer (get-buffer-create " *Gutter Area*"))) (if no-restore nil ; just preparing to put another msg up (if progress-stack @@ -383,7 +396,7 @@ (setcdr top message) (if (eq tmsg message) (set-image-instance-property - (glyph-image-instance progress-glyph) + (glyph-image-instance progress-gauge-glyph) :percent value) (raw-append-progress message value frame)) (redisplay-gutter-area)) @@ -397,9 +410,8 @@ (unless (equal message "") (let ((inhibit-read-only t) (zmacs-region-stays zmacs-region-stays) - (str (concat message "\n\n")) (val (or value 0))) ; preserve from change - (insert-string message (get-buffer " *Gutter Area*")) + (insert-string message (get-buffer-create " *Gutter Area*")) ;; Do what the device is able to cope with. (if (not (valid-image-instantiator-format-p 'progress-gauge frame)) (progn @@ -410,17 +422,27 @@ (if (not executing-kbd-macro) (redisplay-echo-area))) ;; do some funky display here. - (set-extent-begin-glyph - (make-extent (1- (length str)) (1- (length str)) str) - progress-layout-glyph) + (unless progress-text-and-extent + (setq progress-text-and-extent "") + (set-extent-begin-glyph (make-extent 0 0 progress-text-and-extent) + progress-layout-glyph)) + ;; fixup the gutter specifiers + (set-specifier bottom-gutter progress-text-and-extent frame) (set-specifier bottom-gutter-border-width 2 frame) - (set-specifier bottom-gutter str frame) - (set-specifier bottom-gutter-height 'autodetect frame) - (set-specifier bottom-gutter-visible-p t frame) + (set-image-instance-property + (glyph-image-instance progress-gauge-glyph) :percent val) (set-image-instance-property - (glyph-image-instance progress-glyph) :percent val) - (redisplay-gutter-area) - )))) + (glyph-image-instance progress-text-glyph) :data message) + (if (and (eq (specifier-instance bottom-gutter-height frame) + 'autodetect) + (specifier-instance bottom-gutter-visible-p frame)) + ;; if the gauge is already visible then just draw the gutter + (redisplay-gutter-area) + ;; otherwise make the gutter visible and redraw the frame + (set-specifier bottom-gutter-height 'autodetect frame) + (set-specifier bottom-gutter-visible-p t frame) + (redisplay-frame)) + )))) (defun display-progress (label message &optional value frame) "Display a progress gauge and message in the bottom gutter area. @@ -448,7 +470,7 @@ (prog1 nil (clear-progress nil)) (let ((str (apply 'format fmt args))) - (display-progress 'progress str value args) + (display-progress 'progress str value) str))) (defun lprogress (label fmt &optional value &rest args) Index: src/glyphs-widget.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/Attic/glyphs-widget.c,v retrieving revision 1.1.2.10 diff -u -r1.1.2.10 glyphs-widget.c --- src/glyphs-widget.c 1999/08/24 08:38:41 1.1.2.10 +++ src/glyphs-widget.c 1999/09/07 14:20:03 @@ -115,7 +115,7 @@ } static void -check_valid_glyph_or_image (Lisp_Object data) +check_valid_glyph_or_instantiator (Lisp_Object data) { Lisp_Object glyph = data; if (SYMBOLP (data)) @@ -123,7 +123,7 @@ if (IMAGE_INSTANCEP (glyph)) CHECK_IMAGE_INSTANCE (glyph); - else if (!CONSP (glyph)) + else if (!CONSP (glyph) && !VECTORP (glyph)) CHECK_BUFFER_GLYPH (glyph); } @@ -147,7 +147,8 @@ check_valid_border (Lisp_Object data) { if (!EQ (data, Qt) && !EQ (data, Qetched_in) && !EQ (data, Qetched_out) - && !EQ (data, Qbevel_in) && !EQ (data, Qbevel_out)) + && !EQ (data, Qbevel_in) && !EQ (data, Qbevel_out) + && !GLYPHP (data) && !VECTORP (data)) signal_simple_error ("unknown border style for layout", data); } @@ -211,17 +212,57 @@ } static void -check_valid_glyph_or_image_list (Lisp_Object data) +check_valid_glyph_or_instantiator_list (Lisp_Object data) { Lisp_Object rest; CHECK_LIST (data); EXTERNAL_LIST_LOOP (rest, data) { - check_valid_glyph_or_image (XCAR (rest)); + check_valid_glyph_or_instantiator (XCAR (rest)); } } +static Lisp_Object +glyph_instantiator_to_glyph (Lisp_Object sym) +{ + /* This function calls lisp. */ + Lisp_Object glyph = sym; + struct gcpro gcpro1; + + GCPRO1 (glyph); + /* if we have a symbol get at the actual data */ + if (SYMBOLP (glyph)) + glyph = XSYMBOL (glyph)->value; + + if (CONSP (glyph)) + glyph = Feval (glyph); + + /* Be really helpful to the user. */ + if (VECTORP (glyph)) + { + glyph = call1 (intern ("make-glyph"), glyph); + } + + /* substitute the new glyph */ + RETURN_UNGCPRO (glyph); +} + +static void +substitute_keyword_value (Lisp_Object inst, Lisp_Object key, Lisp_Object val) +{ + int i; + /* substitute the new glyph */ + for (i = 0; i < XVECTOR_LENGTH (inst); i++) + { + if (EQ (key, XVECTOR_DATA (inst)[i])) + { + XVECTOR_DATA (inst)[i+1] = val; + break; + } + } +} + /* wire widget property invocations to specific widgets ... The problem we are solving here is that when instantiators get converted to instances they lose some type information (they just become @@ -332,25 +373,9 @@ same reasons we normalize file to data. */ if (!NILP (glyph)) { - int i; - struct gcpro gcpro1; - if (SYMBOLP (glyph)) - glyph = XSYMBOL (glyph)->value; - GCPRO1 (glyph); - - if (CONSP (glyph)) - glyph = Feval (glyph); - /* substitute the new glyph */ - for (i = 0; i < XVECTOR_LENGTH (inst); i++) - { - if (EQ (Q_image, XVECTOR_DATA (inst)[i])) - { - XVECTOR_DATA (inst)[i+1] = glyph; - break; - } - } - UNGCPRO; + substitute_keyword_value (inst, Q_image, glyph_instantiator_to_glyph (glyph)); } + return inst; } @@ -558,7 +583,7 @@ { /* This function can call lisp */ Lisp_Object items = find_keyword_in_vector (inst, Q_items); - + Lisp_Object border = find_keyword_in_vector (inst, Q_border); /* we need to eval glyph if its an expression, we do this for the same reasons we normalize file to data. */ if (!NILP (items)) @@ -566,22 +591,15 @@ Lisp_Object rest; LIST_LOOP (rest, items) { - Lisp_Object glyph = XCAR (rest); - struct gcpro gcpro1; - - /* if we have a symbol get at the actual data */ - if (SYMBOLP (glyph)) - glyph = XSYMBOL (glyph)->value; - GCPRO1 (glyph); - - if (CONSP (glyph)) - glyph = Feval (glyph); /* substitute the new glyph */ - Fsetcar (rest, glyph); - - UNGCPRO; + Fsetcar (rest, glyph_instantiator_to_glyph (XCAR (rest))); } } + /* normalize the border spec. */ + if (VECTORP (border) || CONSP (border)) + { + substitute_keyword_value (inst, Q_border, glyph_instantiator_to_glyph (border)); + } return inst; } @@ -602,7 +620,7 @@ Lisp_Object border = find_keyword_in_vector (instantiator, Q_border); Lisp_Object children = Qnil; int pw = 0, ph = 0, x, y, maxph = 0, maxpw = 0, nitems = 0, - horiz_spacing, vert_spacing; + horiz_spacing, vert_spacing, ph_adjust = 0; if (NILP (frame)) signal_simple_error ("No selected frame", device); @@ -622,6 +640,7 @@ IMAGE_INSTANCE_SUBWINDOW_DISPLAYEDP (ii) = 0; IMAGE_INSTANCE_SUBWINDOW_FRAME (ii) = frame; IMAGE_INSTANCE_LAYOUT_BORDER (ii) = border; + /* normalize size information */ if (!NILP (width)) pw = XINT (width); @@ -669,22 +688,39 @@ else horiz_spacing = (pw - maxpw) / 2; + /* Do the border now so that we can adjust the layout. */ + if (GLYPHP (border)) + { + /* We are going to be sneaky here and add the border text as + just another child, the layout and output routines don't know + this and will just display at the offsets we prescribe. */ + Lisp_Object bglyph = glyph_image_instance (border, domain, ERROR_ME, 1); + + children = Fcons (bglyph, children); + XIMAGE_INSTANCE_XOFFSET (bglyph) = 10; /* Really, what should this be? */ + XIMAGE_INSTANCE_YOFFSET (bglyph) = 0; + + ph_adjust = (glyph_height (border, Qnil, DEFAULT_INDEX, domain) / 2); + IMAGE_INSTANCE_LAYOUT_BORDER (ii) = make_int (ph_adjust); + } + + /* Work out vertical spacings. */ if (!ph) { vert_spacing = WIDGET_BORDER_HEIGHT * 2; if (EQ (orient, Qvertical)) - ph = maxph + (nitems + 1) * vert_spacing; + ph = maxph + (nitems + 1) * vert_spacing + ph_adjust; else - ph = maxph + 2 * vert_spacing; + ph = maxph + 2 * vert_spacing + ph_adjust; } else if (ph < maxph) vert_spacing = WIDGET_BORDER_HEIGHT * 2; else if (EQ (orient, Qvertical)) - vert_spacing = (ph - maxph) / (nitems + 1); + vert_spacing = (ph - (maxph + ph_adjust)) / (nitems + 1); else - vert_spacing = (ph - maxph) / 2; + vert_spacing = (ph - (maxph + ph_adjust)) / 2; - y = vert_spacing; + y = vert_spacing + ph_adjust; x = horiz_spacing; /* Now flip through putting items where we want them, paying @@ -795,7 +831,8 @@ IIFORMAT_HAS_SHARED_METHOD (button, possible_dest_types, widget); IIFORMAT_HAS_SHARED_METHOD (button, instantiate, widget); IIFORMAT_HAS_SHARED_METHOD (button, normalize, widget); - IIFORMAT_VALID_KEYWORD (button, Q_image, check_valid_glyph_or_image); + IIFORMAT_VALID_KEYWORD (button, + Q_image, check_valid_glyph_or_instantiator); VALID_WIDGET_KEYWORDS (button); VALID_GUI_KEYWORDS (button); @@ -873,7 +910,8 @@ IIFORMAT_VALID_KEYWORD (layout, Q_orientation, check_valid_orientation); IIFORMAT_VALID_KEYWORD (layout, Q_justify, check_valid_justification); IIFORMAT_VALID_KEYWORD (layout, Q_border, check_valid_border); - IIFORMAT_VALID_KEYWORD (layout, Q_items, check_valid_glyph_or_image_list); + IIFORMAT_VALID_KEYWORD (layout, Q_items, + check_valid_glyph_or_instantiator_list); #if 0 /* group */ Index: src/glyphs.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/glyphs.c,v retrieving revision 1.23.2.23 diff -u -r1.23.2.23 glyphs.c --- src/glyphs.c 1999/09/02 16:45:41 1.23.2.23 +++ src/glyphs.c 1999/09/07 14:20:16 @@ -77,6 +77,7 @@ DEFINE_IMAGE_INSTANTIATOR_FORMAT (string); DEFINE_IMAGE_INSTANTIATOR_FORMAT (formatted_string); DEFINE_IMAGE_INSTANTIATOR_FORMAT (subwindow); +DEFINE_IMAGE_INSTANTIATOR_FORMAT (text); #ifdef HAVE_WINDOW_SYSTEM DEFINE_IMAGE_INSTANTIATOR_FORMAT (xbm); @@ -1360,6 +1361,10 @@ { val = ret; } + else + { + val = Qnil; + } } return val; } @@ -1719,6 +1724,23 @@ incompatible_image_types (instantiator, dest_mask, IMAGE_TEXT_MASK); } +/* set the properties of a string */ +static Lisp_Object +text_set_property (Lisp_Object image_instance, Lisp_Object prop, + Lisp_Object val) +{ + struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance); + + if (EQ (prop, Q_data)) + { + CHECK_STRING (val); + IMAGE_INSTANCE_TEXT_STRING (ii) = val; + + return Qt; + } + return Qunbound; +} + /**************************************************************************** * formatted-string * @@ -4341,6 +4363,9 @@ IIFORMAT_HAS_METHOD (string, instantiate); IIFORMAT_VALID_KEYWORD (string, Q_data, check_valid_string); + /* Do this so we can set strings. */ + INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (text, "text"); + IIFORMAT_HAS_METHOD (text, set_property); INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (formatted_string, "formatted-string"); Index: src/redisplay-output.c =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/src/redisplay-output.c,v retrieving revision 1.11.2.14 diff -u -r1.11.2.14 redisplay-output.c --- src/redisplay-output.c 1999/09/03 04:35:33 1.11.2.14 +++ src/redisplay-output.c 1999/09/07 14:20:26 @@ -1171,7 +1171,7 @@ /**************************************************************************** redisplay_output_layout - Output a widget hierarchy. + Output a widget hierarchy. This can safely call itself recursively. ****************************************************************************/ void redisplay_output_layout (struct window *w, @@ -1208,6 +1208,8 @@ { int edges = 0; enum edge_style style; + int ypos = db->ypos; + int height = dga->height; if (dga->xoffset >= 0) edges |= EDGE_LEFT; @@ -1224,13 +1226,22 @@ style = EDGE_ETCHED_OUT; else if (EQ (IMAGE_INSTANCE_LAYOUT_BORDER (p), Qbevel_in)) style = EDGE_BEVEL_IN; + else if (INTP (IMAGE_INSTANCE_LAYOUT_BORDER (p))) + { + style = EDGE_ETCHED_IN; + if (edges & EDGE_TOP) + { + ypos += XINT (IMAGE_INSTANCE_LAYOUT_BORDER (p)); + height -= XINT (IMAGE_INSTANCE_LAYOUT_BORDER (p)); + } + } else style = EDGE_BEVEL_OUT; MAYBE_DEVMETH (d, bevel_area, - (w, findex, db->xpos, db->ypos, - db->width, db->height, - 2, edges, style)); + (w, findex, db->xpos, + ypos, + dga->width, height, 2, edges, style)); } /* This shrinks the display box to exactly enclose the glyph @@ -1302,12 +1313,14 @@ dl.descent = glyph_descent (child, Qnil, findex, window); dl.top_clip = cdga.yoffset; dl.clip = (dl.ypos + dl.descent) - (cdb.ypos + cdb.height); - + /* output_string doesn't understand offsets in + the same way as other routines - we have to + add the offset to the width so that we + output the full string. */ MAYBE_DEVMETH (d, output_string, (w, &dl, buf, cdb.xpos, cdga.xoffset, cdb.xpos, - cdb.width, findex, 0, - cursor_start, cursor_width, - cursor_height)); + cdga.width + cdga.xoffset, + findex, 0, 0, 0, 0)); Dynarr_reset (buf); } } Index: tests/glyph-test.el =================================================================== RCS file: /usr/CVSroot/XEmacs/xemacs/tests/Attic/glyph-test.el,v retrieving revision 1.1.2.13 diff -u -r1.1.2.13 glyph-test.el --- tests/glyph-test.el 1999/08/31 17:38:29 1.1.2.13 +++ tests/glyph-test.el 1999/09/07 14:20:27 @@ -99,8 +99,7 @@ (make-glyph [button :face modeline-mousable :descriptor "ok" :callback foo - :image (make-glyph - [xpm :file "../etc/xemacs-icon.xpm"])])) + :image [xpm :file "../etc/xemacs-icon.xpm"]])) ;; normal pushbutton (set-extent-begin-glyph @@ -145,12 +144,12 @@ [layout :pixel-width 200 :pixel-height 250 :orientation vertical :justify left - :border etched-in - :items ((make-glyph - [layout :orientation horizontal - :items (radio-button1 radio-button2)]) + :border [string :data "Hello There Mrs"] + :items (;[layout :orientation horizontal + ;:items (radio-button1 radio-button2)] + radio-button1 radio-button2 edit-field toggle-button label str)])) (set-glyph-face layout 'gui-element) -(set-extent-begin-glyph +(set-extent-begin-glyph (make-extent (point) (point)) layout)