Mercurial > hg > xemacs-beta

comparison src/device.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 8de8e3f6228a
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
1 /* Generic device functions.
2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1994, 1995 Free Software Foundation, Inc.
4 Copyright (C) 1995, 1996 Ben Wing
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
22
23 /* Synched up with: Not in FSF. */
24
25 /* Original version by Chuck Thompson;
26 rewritten and expanded by Ben Wing. */
27
28 #include <config.h>
29 #include "lisp.h"
30
31 #include "buffer.h"
32 #include "console.h"
33 #include "device.h"
34 #include "elhash.h"
35 #include "events.h"
36 #include "faces.h"
37 #include "frame.h"
38 #include "keymap.h"
39 #include "redisplay.h"
40 #include "specifier.h"
41 #include "sysdep.h"
42 #include "window.h"
43
44 #ifdef HAVE_SCROLLBARS
45 #include "scrollbar.h"
46 #endif
47
48 #include "syssignal.h"
49
50 /* Vdefault_device is the firstly-created non-stream device that's still
51 around. We don't really use it anywhere currently, but it might
52 be used for resourcing at some point. (Currently we use
53 Vdefault_x_device.) */
54 Lisp_Object Vdefault_device;
55
56 Lisp_Object Vcreate_device_hook, Vdelete_device_hook;
57
58 /* Device classes */
59 /* Qcolor defined in general.c */
60 Lisp_Object Qgrayscale, Qmono;
61
62 /* Device metrics symbols */
63 Lisp_Object
64 Qcolor_default, Qcolor_select, Qcolor_balloon, Qcolor_3d_face,
65 Qcolor_3d_light, Qcolor_3d_dark, Qcolor_menu, Qcolor_menu_highlight,
66 Qcolor_menu_button, Qcolor_menu_disabled, Qcolor_toolbar,
67 Qcolor_scrollbar, Qcolor_desktop, Qcolor_workspace, Qfont_default,
68 Qfont_menubar, Qfont_dialog, Qsize_cursor, Qsize_scrollbar,
69 Qsize_menu, Qsize_toolbar, Qsize_toolbar_button,
70 Qsize_toolbar_border, Qsize_icon, Qsize_icon_small, Qsize_device,
71 Qsize_workspace, Qsize_device_mm, Qdevice_dpi, Qnum_bit_planes,
72 Qnum_color_cells, Qmouse_buttons, Qswap_buttons, Qshow_sounds,
73 Qslow_device, Qsecurity;
74
75 Lisp_Object Qdevicep, Qdevice_live_p;
76 Lisp_Object Qcreate_device_hook;
77 Lisp_Object Qdelete_device_hook;
78 Lisp_Object Vdevice_class_list;
79
80
81 static Lisp_Object
82 mark_device (Lisp_Object obj)
83 {
84 struct device *d = XDEVICE (obj);
85
86 mark_object (d->name);
87 mark_object (d->connection);
88 mark_object (d->canon_connection);
89 mark_object (d->console);
90 mark_object (d->selected_frame);
91 mark_object (d->frame_with_focus_real);
92 mark_object (d->frame_with_focus_for_hooks);
93 mark_object (d->frame_that_ought_to_have_focus);
94 mark_object (d->device_class);
95 mark_object (d->user_defined_tags);
96 mark_object (d->pixel_to_glyph_cache.obj1);
97 mark_object (d->pixel_to_glyph_cache.obj2);
98
99 mark_object (d->color_instance_cache);
100 mark_object (d->font_instance_cache);
101 #ifdef MULE
102 mark_object (d->charset_font_cache);
103 #endif
104 mark_object (d->image_instance_cache);
105
106 if (d->devmeths)
107 {
108 mark_object (d->devmeths->symbol);
109 MAYBE_DEVMETH (d, mark_device, (d));
110 }
111
112 return (d->frame_list);
113 }
114
115 static void
116 print_device (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
117 {
118 struct device *d = XDEVICE (obj);
119 char buf[256];
120
121 if (print_readably)
122 error ("printing unreadable object #<device %s 0x%x>",
123 XSTRING_DATA (d->name), d->header.uid);
124
125 sprintf (buf, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" :
126 DEVICE_TYPE_NAME (d));
127 write_c_string (buf, printcharfun);
128 if (DEVICE_LIVE_P (d))
129 {
130 write_c_string (" on ", printcharfun);
131 print_internal (DEVICE_CONNECTION (d), printcharfun, 1);
132 }
133 sprintf (buf, " 0x%x>", d->header.uid);
134 write_c_string (buf, printcharfun);
135 }
136
137 DEFINE_LRECORD_IMPLEMENTATION ("device", device,
138 mark_device, print_device, 0, 0, 0, 0,
139 struct device);
140
141 int
142 valid_device_class_p (Lisp_Object class)
143 {
144 return !NILP (memq_no_quit (class, Vdevice_class_list));
145 }
146
147 DEFUN ("valid-device-class-p", Fvalid_device_class_p, 1, 1, 0, /*
148 Given a DEVICE-CLASS, return t if it is valid.
149 Valid classes are 'color, 'grayscale, and 'mono.
150 */
151 (device_class))
152 {
153 return valid_device_class_p (device_class) ? Qt : Qnil;
154 }
155
156 DEFUN ("device-class-list", Fdevice_class_list, 0, 0, 0, /*
157 Return a list of valid device classes.
158 */
159 ())
160 {
161 return Fcopy_sequence (Vdevice_class_list);
162 }
163
164 static struct device *
165 allocate_device (Lisp_Object console)
166 {
167 Lisp_Object device;
168 struct device *d = alloc_lcrecord_type (struct device, &lrecord_device);
169 struct gcpro gcpro1;
170
171 zero_lcrecord (d);
172
173 XSETDEVICE (device, d);
174 GCPRO1 (device);
175
176 d->name = Qnil;
177 d->console = console;
178 d->connection = Qnil;
179 d->canon_connection = Qnil;
180 d->frame_list = Qnil;
181 d->selected_frame = Qnil;
182 d->frame_with_focus_real = Qnil;
183 d->frame_with_focus_for_hooks = Qnil;
184 d->frame_that_ought_to_have_focus = Qnil;
185 d->device_class = Qnil;
186 d->user_defined_tags = Qnil;
187 d->pixel_to_glyph_cache.obj1 = Qnil;
188 d->pixel_to_glyph_cache.obj2 = Qnil;
189
190 d->infd = d->outfd = -1;
191
192 /* #### is 20 reasonable? */
193 d->color_instance_cache =
194 make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL);
195 d->font_instance_cache =
196 make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL);
197 #ifdef MULE
198 /* Note that the following table is bi-level. */
199 d->charset_font_cache =
200 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
201 #endif
202 /*
203 Note that the image instance cache is actually bi-level.
204 See device.h. We use a low number here because most of the
205 time there aren't very many different masks that will be used.
206 */
207 d->image_instance_cache =
208 make_lisp_hash_table (5, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
209
210 UNGCPRO;
211 return d;
212 }
213
214 struct device *
215 decode_device (Lisp_Object device)
216 {
217 if (NILP (device))
218 device = Fselected_device (Qnil);
219 /* quietly accept frames for the device arg */
220 else if (FRAMEP (device))
221 device = FRAME_DEVICE (decode_frame (device));
222 CHECK_LIVE_DEVICE (device);
223 return XDEVICE (device);
224 }
225
226 DEFUN ("dfw-device", Fdfw_device, 1, 1, 0, /*
227 Given a device, frame, or window, return the associated device.
228 Return nil otherwise.
229 */
230 (obj))
231 {
232 return DFW_DEVICE (obj);
233 }
234
235
236 DEFUN ("selected-device", Fselected_device, 0, 1, 0, /*
237 Return the device which is currently active.
238 If optional CONSOLE is non-nil, return the device that would be currently
239 active if CONSOLE were the selected console.
240 */
241 (console))
242 {
243 if (NILP (console) && NILP (Vselected_console))
244 return Qnil; /* happens early in temacs */
245 return CONSOLE_SELECTED_DEVICE (decode_console (console));
246 }
247
248 /* Called from selected_frame_1(), called from Fselect_window() */
249 void
250 select_device_1 (Lisp_Object device)
251 {
252 struct device *dev = XDEVICE (device);
253 Lisp_Object old_selected_device = Fselected_device (Qnil);
254
255 if (EQ (device, old_selected_device))
256 return;
257
258 /* now select the device's console */
259 CONSOLE_SELECTED_DEVICE (XCONSOLE (DEVICE_CONSOLE (dev))) = device;
260 select_console_1 (DEVICE_CONSOLE (dev));
261 }
262
263 DEFUN ("select-device", Fselect_device, 1, 1, 0, /*
264 Select the device DEVICE.
265 Subsequent editing commands apply to its console, selected frame,
266 and selected window.
267 The selection of DEVICE lasts until the next time the user does
268 something to select a different device, or until the next time this
269 function is called.
270 */
271 (device))
272 {
273 CHECK_LIVE_DEVICE (device);
274
275 /* select the device's selected frame's selected window. This will call
276 selected_frame_1()->selected_device_1()->selected_console_1(). */
277 if (!NILP (DEVICE_SELECTED_FRAME (XDEVICE (device))))
278 Fselect_window (FRAME_SELECTED_WINDOW
279 (XFRAME (DEVICE_SELECTED_FRAME (XDEVICE (device)))),
280 Qnil);
281 else
282 error ("Can't select a device with no frames");
283 return Qnil;
284 }
285
286 void
287 set_device_selected_frame (struct device *d, Lisp_Object frame)
288 {
289 if (!NILP (frame) && !FRAME_MINIBUF_ONLY_P (XFRAME (frame)))
290 set_console_last_nonminibuf_frame (XCONSOLE (DEVICE_CONSOLE (d)), frame);
291 d->selected_frame = frame;
292 }
293
294 DEFUN ("set-device-selected-frame", Fset_device_selected_frame, 2, 2, 0, /*
295 Set the selected frame of device object DEVICE to FRAME.
296 If DEVICE is nil, the selected device is used.
297 If DEVICE is the selected device, this makes FRAME the selected frame.
298 */
299 (device, frame))
300 {
301 XSETDEVICE (device, decode_device (device));
302 CHECK_LIVE_FRAME (frame);
303
304 if (! EQ (device, FRAME_DEVICE (XFRAME (frame))))
305 error ("In `set-device-selected-frame', FRAME is not on DEVICE");
306
307 if (EQ (device, Fselected_device (Qnil)))
308 return Fselect_frame (frame);
309
310 set_device_selected_frame (XDEVICE (device), frame);
311 return frame;
312 }
313
314 DEFUN ("devicep", Fdevicep, 1, 1, 0, /*
315 Return non-nil if OBJECT is a device.
316 */
317 (object))
318 {
319 return DEVICEP (object) ? Qt : Qnil;
320 }
321
322 DEFUN ("device-live-p", Fdevice_live_p, 1, 1, 0, /*
323 Return non-nil if OBJECT is a device that has not been deleted.
324 */
325 (object))
326 {
327 return DEVICEP (object) && DEVICE_LIVE_P (XDEVICE (object)) ? Qt : Qnil;
328 }
329
330 DEFUN ("device-name", Fdevice_name, 0, 1, 0, /*
331 Return the name of the specified device.
332 DEVICE defaults to the selected device if omitted.
333 */
334 (device))
335 {
336 return DEVICE_NAME (decode_device (device));
337 }
338
339 DEFUN ("device-connection", Fdevice_connection, 0, 1, 0, /*
340 Return the connection of the specified device.
341 DEVICE defaults to the selected device if omitted.
342 */
343 (device))
344 {
345 return DEVICE_CONNECTION (decode_device (device));
346 }
347
348 DEFUN ("device-console", Fdevice_console, 0, 1, 0, /*
349 Return the console of the specified device.
350 DEVICE defaults to the selected device if omitted.
351 */
352 (device))
353 {
354 return DEVICE_CONSOLE (decode_device (device));
355 }
356
357 #ifdef HAVE_WINDOW_SYSTEM
358
359 static void
360 init_global_resources (struct device *d)
361 {
362 init_global_faces (d);
363 #ifdef HAVE_SCROLLBARS
364 init_global_scrollbars (d);
365 #endif
366 #ifdef HAVE_TOOLBARS
367 init_global_toolbars (d);
368 #endif
369 }
370
371 #endif
372
373 static void
374 init_device_resources (struct device *d)
375 {
376 init_device_faces (d);
377 #ifdef HAVE_SCROLLBARS
378 init_device_scrollbars (d);
379 #endif
380 #ifdef HAVE_TOOLBARS
381 init_device_toolbars (d);
382 #endif
383 }
384
385 static Lisp_Object
386 semi_canonicalize_device_connection (struct console_methods *meths,
387 Lisp_Object name, Error_behavior errb)
388 {
389 return CONTYPE_METH_OR_GIVEN (meths, semi_canonicalize_device_connection,
390 (name, errb), name);
391 }
392
393 static Lisp_Object
394 canonicalize_device_connection (struct console_methods *meths,
395 Lisp_Object name, Error_behavior errb)
396 {
397 return CONTYPE_METH_OR_GIVEN (meths, canonicalize_device_connection,
398 (name, errb), name);
399 }
400
401 static Lisp_Object
402 find_device_of_type (struct console_methods *meths, Lisp_Object canon)
403 {
404 Lisp_Object devcons, concons;
405
406 DEVICE_LOOP_NO_BREAK (devcons, concons)
407 {
408 Lisp_Object device = XCAR (devcons);
409
410 if (EQ (CONMETH_TYPE (meths), DEVICE_TYPE (XDEVICE (device)))
411 && internal_equal (DEVICE_CANON_CONNECTION (XDEVICE (device)),
412 canon, 0))
413 return device;
414 }
415
416 return Qnil;
417 }
418
419 DEFUN ("find-device", Ffind_device, 1, 2, 0, /*
420 Look for an existing device attached to connection CONNECTION.
421 Return the device if found; otherwise, return nil.
422
423 If TYPE is specified, only return devices of that type; otherwise,
424 return devices of any type. (It is possible, although unlikely,
425 that two devices of different types could have the same connection
426 name; in such a case, the first device found is returned.)
427 */
428 (connection, type))
429 {
430 Lisp_Object canon = Qnil;
431 struct gcpro gcpro1;
432
433 GCPRO1 (canon);
434
435 if (!NILP (type))
436 {
437 struct console_methods *conmeths = decode_console_type (type, ERROR_ME);
438 canon = canonicalize_device_connection (conmeths, connection,
439 ERROR_ME_NOT);
440 if (UNBOUNDP (canon))
441 RETURN_UNGCPRO (Qnil);
442
443 RETURN_UNGCPRO (find_device_of_type (conmeths, canon));
444 }
445 else
446 {
447 int i;
448
449 for (i = 0; i < Dynarr_length (the_console_type_entry_dynarr); i++)
450 {
451 struct console_methods *conmeths =
452 Dynarr_at (the_console_type_entry_dynarr, i).meths;
453 canon = canonicalize_device_connection (conmeths, connection,
454 ERROR_ME_NOT);
455 if (!UNBOUNDP (canon))
456 {
457 Lisp_Object device = find_device_of_type (conmeths, canon);
458 if (!NILP (device))
459 RETURN_UNGCPRO (device);
460 }
461 }
462
463 RETURN_UNGCPRO (Qnil);
464 }
465 }
466
467 DEFUN ("get-device", Fget_device, 1, 2, 0, /*
468 Look for an existing device attached to connection CONNECTION.
469 Return the device if found; otherwise, signal an error.
470
471 If TYPE is specified, only return devices of that type; otherwise,
472 return devices of any type. (It is possible, although unlikely,
473 that two devices of different types could have the same connection
474 name; in such a case, the first device found is returned.)
475 */
476 (connection, type))
477 {
478 Lisp_Object device = Ffind_device (connection, type);
479 if (NILP (device))
480 {
481 if (NILP (type))
482 signal_simple_error ("No such device", connection);
483 else
484 signal_simple_error_2 ("No such device", type, connection);
485 }
486 return device;
487 }
488
489 static Lisp_Object
490 delete_deviceless_console (Lisp_Object console)
491 {
492 if (NILP (XCONSOLE (console)->device_list))
493 Fdelete_console (console, Qnil);
494 return Qnil;
495 }
496
497 DEFUN ("make-device", Fmake_device, 2, 3, 0, /*
498 Return a new device of type TYPE, attached to connection CONNECTION.
499
500 The valid values for CONNECTION are device-specific; however,
501 CONNECTION is generally a string. (Specifically, for X devices,
502 CONNECTION should be a display specification such as "foo:0", and
503 for TTY devices, CONNECTION should be the filename of a TTY device
504 file, such as "/dev/ttyp4", or nil to refer to XEmacs' standard
505 input/output.)
506
507 PROPS, if specified, should be a plist of properties controlling
508 device creation.
509
510 If CONNECTION specifies an already-existing device connection, that
511 device is simply returned; no new device is created, and PROPS
512 have no effect.
513 */
514 (type, connection, props))
515 {
516 /* This function can GC */
517 struct device *d;
518 struct console *con;
519 Lisp_Object device = Qnil;
520 Lisp_Object console = Qnil;
521 Lisp_Object name = Qnil;
522 struct console_methods *conmeths;
523 int speccount = specpdl_depth();
524
525 struct gcpro gcpro1, gcpro2, gcpro3;
526 #ifdef HAVE_X_WINDOWS
527 /* #### icky-poo. If this is the first X device we are creating,
528 then retrieve the global face resources. We have to do it
529 here, at the same time as (or just before) the device face
530 resources are retrieved; specifically, it needs to be done
531 after the device has been created but before any frames have
532 been popped up or much anything else has been done. It's
533 possible for other devices to specify different global
534 resources (there's a property on each X server's root window
535 that holds some resources); tough luck for the moment.
536
537 This is a nasty violation of device independence, but
538 there's not a whole lot I can figure out to do about it.
539 The real problem is that the concept of resources is not
540 generalized away from X. Similar resource-related
541 device-independence violations occur in faces.el. */
542 int first_x_device = NILP (Vdefault_x_device) && EQ (type, Qx);
543 #endif
544
545 GCPRO3 (device, console, name);
546
547 conmeths = decode_console_type (type, ERROR_ME_NOT);
548 if (!conmeths)
549 signal_simple_error ("Invalid device type", type);
550
551 device = Ffind_device (connection, type);
552 if (!NILP (device))
553 RETURN_UNGCPRO (device);
554
555 name = Fplist_get (props, Qname, Qnil);
556
557 {
558 Lisp_Object conconnect =
559 (HAS_CONTYPE_METH_P (conmeths, device_to_console_connection)) ?
560 CONTYPE_METH (conmeths, device_to_console_connection,
561 (connection, ERROR_ME)) :
562 connection;
563 console = create_console (name, type, conconnect, props);
564 }
565
566 record_unwind_protect(delete_deviceless_console, console);
567
568 con = XCONSOLE (console);
569 d = allocate_device (console);
570 XSETDEVICE (device, d);
571
572 d->devmeths = con->conmeths;
573
574 DEVICE_NAME (d) = name;
575 DEVICE_CONNECTION (d) =
576 semi_canonicalize_device_connection (conmeths, connection, ERROR_ME);
577 DEVICE_CANON_CONNECTION (d) =
578 canonicalize_device_connection (conmeths, connection, ERROR_ME);
579
580 MAYBE_DEVMETH (d, init_device, (d, props));
581
582 /* Do it this way so that the device list is in order of creation */
583 con->device_list = nconc2 (con->device_list, Fcons (device, Qnil));
584 RESET_CHANGED_SET_FLAGS;
585 if (NILP (Vdefault_device) || DEVICE_STREAM_P (XDEVICE (Vdefault_device)))
586 Vdefault_device = device;
587
588 init_device_sound (d);
589 #ifdef HAVE_X_WINDOWS
590 if (first_x_device)
591 init_global_resources (d);
592 #endif
593 init_device_resources (d);
594
595 MAYBE_DEVMETH (d, finish_init_device, (d, props));
596
597 /* If this is the first device on the console, make it the selected one. */
598 if (NILP (CONSOLE_SELECTED_DEVICE (con)))
599 CONSOLE_SELECTED_DEVICE (con) = device;
600
601 /* #### the following should trap errors. */
602 setup_device_initial_specifier_tags (d);
603
604 UNGCPRO;
605 unbind_to(speccount, Qnil);
606 return device;
607 }
608
609 /* find a device other than the selected one. Prefer non-stream
610 devices over stream devices. Maybe stay on the same console. */
611
612 static Lisp_Object
613 find_other_device (Lisp_Object device, int on_same_console)
614 {
615 Lisp_Object devcons = Qnil, concons;
616 Lisp_Object console = DEVICE_CONSOLE (XDEVICE (device));
617
618 /* look for a non-stream device */
619 DEVICE_LOOP_NO_BREAK (devcons, concons)
620 {
621 Lisp_Object dev = XCAR (devcons);
622 if (on_same_console && !EQ (console, DEVICE_CONSOLE (XDEVICE (dev))))
623 continue;
624 if (!DEVICE_STREAM_P (XDEVICE (dev)) && !EQ (dev, device) &&
625 !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
626 goto double_break_1;
627 }
628
629 double_break_1:
630 if (!NILP (devcons))
631 return XCAR (devcons);
632
633 /* OK, now look for a stream device */
634 DEVICE_LOOP_NO_BREAK (devcons, concons)
635 {
636 Lisp_Object dev = XCAR (devcons);
637 if (on_same_console && !EQ (console, DEVICE_CONSOLE (XDEVICE (dev))))
638 continue;
639 if (!EQ (dev, device) && !NILP (DEVICE_SELECTED_FRAME (XDEVICE (dev))))
640 goto double_break_2;
641 }
642 double_break_2:
643 if (!NILP (devcons))
644 return XCAR (devcons);
645
646 /* Sorry, there ain't none */
647 return Qnil;
648 }
649
650 static int
651 find_nonminibuffer_frame_not_on_device_predicate (Lisp_Object frame,
652 void *closure)
653 {
654 Lisp_Object device;
655
656 VOID_TO_LISP (device, closure);
657 if (FRAME_MINIBUF_ONLY_P (XFRAME (frame)))
658 return 0;
659 if (EQ (device, FRAME_DEVICE (XFRAME (frame))))
660 return 0;
661 return 1;
662 }
663
664 Lisp_Object
665 find_nonminibuffer_frame_not_on_device (Lisp_Object device)
666 {
667 return find_some_frame (find_nonminibuffer_frame_not_on_device_predicate,
668 LISP_TO_VOID (device));
669 }
670
671
672 /* Delete device D.
673
674 If FORCE is non-zero, allow deletion of the only frame.
675
676 If CALLED_FROM_DELETE_CONSOLE is non-zero, then, if
677 deleting the last device on a console, just delete it,
678 instead of calling `delete-console'.
679
680 If FROM_IO_ERROR is non-zero, then the device is gone due
681 to an I/O error. This affects what happens if we exit
682 (we do an emergency exit instead of `save-buffers-kill-emacs'.)
683 */
684
685 void
686 delete_device_internal (struct device *d, int force,
687 int called_from_delete_console,
688 int from_io_error)
689 {
690 /* This function can GC */
691 struct console *c;
692 Lisp_Object device;
693 struct gcpro gcpro1;
694
695 /* OK to delete an already-deleted device. */
696 if (!DEVICE_LIVE_P (d))
697 return;
698
699 XSETDEVICE (device, d);
700 GCPRO1 (device);
701
702 c = XCONSOLE (DEVICE_CONSOLE (d));
703
704 if (!called_from_delete_console)
705 {
706 int delete_console = 0;
707 /* If we're deleting the only device on the console,
708 delete the console. */
709 if ((XINT (Flength (CONSOLE_DEVICE_LIST (c))) == 1)
710 /* if we just created the device, it might not be listed,
711 or something ... */
712 && !NILP (memq_no_quit (device, CONSOLE_DEVICE_LIST (c))))
713 delete_console = 1;
714 /* Or if there aren't any nonminibuffer frames that would be
715 left, delete the console (this will make XEmacs exit). */
716 else if (NILP (find_nonminibuffer_frame_not_on_device (device)))
717 delete_console = 1;
718
719 if (delete_console)
720 {
721 delete_console_internal (c, force, 0, from_io_error);
722 UNGCPRO;
723 return;
724 }
725 }
726
727 reset_one_device (d);
728
729 {
730 Lisp_Object frmcons;
731
732 /* First delete all frames without their own minibuffers,
733 to avoid errors coming from attempting to delete a frame
734 that is a surrogate for another frame. */
735 DEVICE_FRAME_LOOP (frmcons, d)
736 {
737 struct frame *f = XFRAME (XCAR (frmcons));
738 /* delete_frame_internal() might do anything such as run hooks,
739 so be defensive. */
740 if (FRAME_LIVE_P (f) && !FRAME_HAS_MINIBUF_P (f))
741 delete_frame_internal (f, 1, 1, from_io_error);
742
743 if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
744 go ahead and delete anything */
745 {
746 UNGCPRO;
747 return;
748 }
749 }
750
751 /* #### This should probably be a device method but it is time for
752 19.14 to go out the door. */
753 #ifdef HAVE_X_WINDOWS
754 /* Next delete all frames which have the popup property to avoid
755 deleting a child after its parent. */
756 DEVICE_FRAME_LOOP (frmcons, d)
757 {
758 struct frame *f = XFRAME (XCAR (frmcons));
759
760 if (FRAME_LIVE_P (f))
761 {
762 Lisp_Object popup = Fframe_property (XCAR (frmcons), Qpopup, Qnil);
763 if (!NILP (popup))
764 delete_frame_internal (f, 1, 1, from_io_error);
765
766 if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
767 go ahead and delete anything */
768 {
769 UNGCPRO;
770 return;
771 }
772 }
773 }
774 #endif /* HAVE_X_WINDOWS */
775
776 DEVICE_FRAME_LOOP (frmcons, d)
777 {
778 struct frame *f = XFRAME (XCAR (frmcons));
779 /* delete_frame_internal() might do anything such as run hooks,
780 so be defensive. */
781 if (FRAME_LIVE_P (f))
782 delete_frame_internal (f, 1, 1, from_io_error);
783
784 if (!DEVICE_LIVE_P (d)) /* make sure the delete-*-hook didn't
785 go ahead and delete anything */
786 {
787 UNGCPRO;
788 return;
789 }
790 }
791 }
792
793 set_device_selected_frame (d, Qnil);
794
795 /* try to select another device */
796
797 if (EQ (device, Fselected_device (DEVICE_CONSOLE (d))))
798 {
799 Lisp_Object other_dev = find_other_device (device, 1);
800 if (!NILP (other_dev))
801 Fselect_device (other_dev);
802 }
803
804 if (EQ (device, Vdefault_device))
805 Vdefault_device = find_other_device (device, 0);
806
807 MAYBE_DEVMETH (d, delete_device, (d));
808
809 CONSOLE_DEVICE_LIST (c) = delq_no_quit (device, CONSOLE_DEVICE_LIST (c));
810 RESET_CHANGED_SET_FLAGS;
811 d->devmeths = dead_console_methods;
812 UNGCPRO;
813 }
814
815 /* delete a device as a result of an I/O error. Called from
816 an enqueued magic-eval event. */
817
818 void
819 io_error_delete_device (Lisp_Object device)
820 {
821 /* Note: it's the console that should get deleted, but
822 delete_device_internal() contains a hack that also deletes the
823 console when called from this function. */
824 delete_device_internal (XDEVICE (device), 1, 0, 1);
825 }
826
827 DEFUN ("delete-device", Fdelete_device, 1, 2, 0, /*
828 Delete DEVICE, permanently eliminating it from use.
829 Normally, you cannot delete the last non-minibuffer-only frame (you must
830 use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional
831 second argument FORCE is non-nil, you can delete the last frame. (This
832 will automatically call `save-buffers-kill-emacs'.)
833 */
834 (device, force))
835 {
836 CHECK_DEVICE (device);
837 delete_device_internal (XDEVICE (device), !NILP (force), 0, 0);
838 return Qnil;
839 }
840
841 DEFUN ("device-frame-list", Fdevice_frame_list, 0, 1, 0, /*
842 Return a list of all frames on DEVICE.
843 If DEVICE is nil, the selected device will be used.
844 */
845 (device))
846 {
847 return Fcopy_sequence (DEVICE_FRAME_LIST (decode_device (device)));
848 }
849
850 DEFUN ("device-class", Fdevice_class, 0, 1, 0, /*
851 Return the class (color behavior) of DEVICE.
852 This will be one of 'color, 'grayscale, or 'mono.
853 */
854 (device))
855 {
856 return DEVICE_CLASS (decode_device (device));
857 }
858
859 DEFUN ("set-device-class", Fset_device_class, 2, 2, 0, /*
860 Set the class (color behavior) of DEVICE.
861 CLASS should be one of 'color, 'grayscale, or 'mono.
862 This is only allowed on device such as TTY devices, where the color
863 behavior cannot necessarily be determined automatically.
864 */
865 (device, class))
866 {
867 struct device *d = decode_device (device);
868 XSETDEVICE (device, d);
869 if (!DEVICE_TTY_P (d))
870 signal_simple_error ("Cannot change the class of this device", device);
871 if (!EQ (class, Qcolor) && !EQ (class, Qmono) && !EQ (class, Qgrayscale))
872 signal_simple_error ("Must be color, mono, or grayscale", class);
873 if (! EQ (DEVICE_CLASS (d), class))
874 {
875 Lisp_Object frmcons;
876 DEVICE_CLASS (d) = class;
877 DEVICE_FRAME_LOOP (frmcons, d)
878 {
879 struct frame *f = XFRAME (XCAR (frmcons));
880
881 recompute_all_cached_specifiers_in_frame (f);
882 MARK_FRAME_FACES_CHANGED (f);
883 MARK_FRAME_GLYPHS_CHANGED (f);
884 MARK_FRAME_SUBWINDOWS_CHANGED (f);
885 MARK_FRAME_TOOLBARS_CHANGED (f);
886 f->menubar_changed = 1;
887 }
888 }
889 return Qnil;
890 }
891
892 DEFUN ("set-device-baud-rate", Fset_device_baud_rate, 2, 2, 0, /*
893 Set the output baud rate of DEVICE to RATE.
894 On most systems, changing this value will affect the amount of padding
895 and other strategic decisions made during redisplay.
896 */
897 (device, rate))
898 {
899 CHECK_INT (rate);
900
901 DEVICE_BAUD_RATE (decode_device (device)) = XINT (rate);
902
903 return rate;
904 }
905
906 DEFUN ("device-baud-rate", Fdevice_baud_rate, 0, 1, 0, /*
907 Return the output baud rate of DEVICE.
908 */
909 (device))
910 {
911 return make_int (DEVICE_BAUD_RATE (decode_device (device)));
912 }
913
914 DEFUN ("device-system-metric", Fdevice_system_metric, 1, 3, 0, /*
915 Get a metric for DEVICE as provided by the system.
916
917 METRIC must be a symbol specifying requested metric. Note that the metrics
918 returned are these provided by the system internally, not read from resources,
919 so obtained from the most internal level.
920
921 If a metric is not provided by the system, then DEFAULT is returned.
922
923 When DEVICE is nil, selected device is assumed
924
925 Metrics, by group, are:
926
927 COLORS. Colors are returned as valid color instantiators. No other assumption
928 on the returned value should be made (i.e. it can be a string on one system but
929 a color instance on another). For colors, returned value is a cons of
930 foreground and background colors. Note that if the system provides only one
931 color of the pair, the second one may be nil.
932
933 color-default Standard window text foreground and background.
934 color-select Selection highlight text and background colors.
935 color-balloon Balloon popup text and background colors.
936 color-3d-face 3-D object (button, modeline) text and surface colors.
937 color-3d-light Fore and back colors for 3-D edges facing light source.
938 color-3d-dark Fore and back colors for 3-D edges facing away from
939 light source.
940 color-menu Text and background for menus
941 color-menu-highlight Selected menu item colors
942 color-menu-button Menu button colors
943 color-menu-disabled Unselectable menu item colors
944 color-toolbar Toolbar foreground and background colors
945 color-scrollbar Scrollbar foreground and background colors
946 color-desktop Desktop window colors
947 color-workspace Workspace window colors
948
949 FONTS. Fonts are returned as valid font instantiators. No other assumption on
950 the returned value should be made (i.e. it can be a string on one system but
951 font instance on another).
952
953 font-default Default fixed width font.
954 font-menubar Menubar font
955 font-dialog Dialog boxes font
956
957 GEOMETRY. These metrics are returned as conses of (X . Y). As with colors,
958 either car or cdr of the cons may be nil if the system does not provide one
959 of the corresponding dimensions.
960
961 size-cursor Mouse cursor size.
962 size-scrollbar Scrollbars (WIDTH . HEIGHT)
963 size-menu Menubar height, as (nil . HEIGHT)
964 size-toolbar Toolbar width and height.
965 size-toolbar-button Toolbar button size.
966 size-toolbar-border Toolbar border width and height.
967 size-icon Icon dimensions.
968 size-icon-small Small icon dimensions.
969 size-device Device screen size in pixels.
970 size-workspace Workspace size in pixels. This can be less than the
971 above if window manager has decorations which
972 effectively shrink the area remaining for application
973 windows.
974 size-device-mm Device screen size in millimeters.
975 device-dpi Device resolution, in dots per inch.
976 num-bit-planes Integer, number of device bit planes.
977 num-color-cells Integer, number of device color cells.
978
979 FEATURES. This group reports various device features. If a feature is
980 present, integer 1 (one) is returned, if it is not present, then integer
981 0 (zero) is returned. If the system is unaware of the feature, then
982 DEFAULT is returned.
983
984 mouse-buttons Integer, number of mouse buttons, or zero if no mouse.
985 swap-buttons Non-zero if left and right mouse buttons are swapped.
986 show-sounds User preference for visual over audible bell.
987 slow-device Device is slow, avoid animation.
988 security Non-zero if user environment is secure.
989 */
990 (device, metric, default_))
991 {
992 struct device *d = decode_device (device);
993 enum device_metrics m;
994 Lisp_Object res;
995
996 /* Decode metric */
997 #define FROB(met) \
998 else if (EQ (metric, Q##met)) \
999 m = DM_##met
1000
1001 if (0)
1002 ;
1003 FROB (color_default);
1004 FROB (color_select);
1005 FROB (color_balloon);
1006 FROB (color_3d_face);
1007 FROB (color_3d_light);
1008 FROB (color_3d_dark);
1009 FROB (color_menu);
1010 FROB (color_menu_highlight);
1011 FROB (color_menu_button);
1012 FROB (color_menu_disabled);
1013 FROB (color_toolbar);
1014 FROB (color_scrollbar);
1015 FROB (color_desktop);
1016 FROB (color_workspace);
1017 FROB (font_default);
1018 FROB (font_menubar);
1019 FROB (font_dialog);
1020 FROB (size_cursor);
1021 FROB (size_scrollbar);
1022 FROB (size_menu);
1023 FROB (size_toolbar);
1024 FROB (size_toolbar_button);
1025 FROB (size_toolbar_border);
1026 FROB (size_icon);
1027 FROB (size_icon_small);
1028 FROB (size_device);
1029 FROB (size_workspace);
1030 FROB (size_device_mm);
1031 FROB (device_dpi);
1032 FROB (num_bit_planes);
1033 FROB (num_color_cells);
1034 FROB (mouse_buttons);
1035 FROB (swap_buttons);
1036 FROB (show_sounds);
1037 FROB (slow_device);
1038 FROB (security);
1039 else
1040 signal_simple_error ("Invalid device metric symbol", metric);
1041
1042 res = DEVMETH_OR_GIVEN (d, device_system_metrics, (d, m), Qunbound);
1043 return UNBOUNDP(res) ? default_ : res;
1044
1045 #undef FROB
1046 }
1047
1048 DEFUN ("device-system-metrics", Fdevice_system_metrics, 0, 1, 0, /*
1049 Get a property list of device metric for DEVICE.
1050
1051 See `device-system-metric' for the description of available metrics.
1052 DEVICE defaults to selected device when omitted.
1053 */
1054 (device))
1055 {
1056 struct device *d = decode_device (device);
1057 Lisp_Object plist = Qnil, one_metric;
1058
1059 #define FROB(m) \
1060 if (!UNBOUNDP ((one_metric = \
1061 DEVMETH_OR_GIVEN (d, device_system_metrics, \
1062 (d, DM_##m), Qunbound)))) \
1063 plist = Fcons (Q##m, Fcons (one_metric, plist));
1064
1065 FROB (color_default);
1066 FROB (color_select);
1067 FROB (color_balloon);
1068 FROB (color_3d_face);
1069 FROB (color_3d_light);
1070 FROB (color_3d_dark);
1071 FROB (color_menu);
1072 FROB (color_menu_highlight);
1073 FROB (color_menu_button);
1074 FROB (color_menu_disabled);
1075 FROB (color_toolbar);
1076 FROB (color_scrollbar);
1077 FROB (color_desktop);
1078 FROB (color_workspace);
1079 FROB (font_default);
1080 FROB (font_menubar);
1081 FROB (font_dialog);
1082 FROB (size_cursor);
1083 FROB (size_scrollbar);
1084 FROB (size_menu);
1085 FROB (size_toolbar);
1086 FROB (size_toolbar_button);
1087 FROB (size_toolbar_border);
1088 FROB (size_icon);
1089 FROB (size_icon_small);
1090 FROB (size_device);
1091 FROB (size_workspace);
1092 FROB (size_device_mm);
1093 FROB (device_dpi);
1094 FROB (num_bit_planes);
1095 FROB (num_color_cells);
1096 FROB (mouse_buttons);
1097 FROB (swap_buttons);
1098 FROB (show_sounds);
1099 FROB (slow_device);
1100 FROB (security);
1101
1102 return plist;
1103
1104 #undef FROB
1105 }
1106
1107 Lisp_Object
1108 domain_device_type (Lisp_Object domain)
1109 {
1110 /* This cannot GC */
1111 assert (WINDOWP (domain) || FRAMEP (domain)
1112 || DEVICEP (domain) || CONSOLEP (domain));
1113
1114 if (WINDOWP (domain))
1115 {
1116 if (!WINDOW_LIVE_P (XWINDOW (domain)))
1117 return Qdead;
1118 domain = WINDOW_FRAME (XWINDOW (domain));
1119 }
1120 if (FRAMEP (domain))
1121 {
1122 if (!FRAME_LIVE_P (XFRAME (domain)))
1123 return Qdead;
1124 domain = FRAME_DEVICE (XFRAME (domain));
1125 }
1126 if (DEVICEP (domain))
1127 {
1128 if (!DEVICE_LIVE_P (XDEVICE (domain)))
1129 return Qdead;
1130 domain = DEVICE_CONSOLE (XDEVICE (domain));
1131 }
1132 return CONSOLE_TYPE (XCONSOLE (domain));
1133 }
1134
1135 /*
1136 * Determine whether window system bases window geometry on character
1137 * or pixel counts.
1138 * Return non-zero for pixel-based geometry, zero for character-based.
1139 */
1140 int
1141 window_system_pixelated_geometry (Lisp_Object domain)
1142 {
1143 /* This cannot GC */
1144 Lisp_Object winsy = domain_device_type (domain);
1145 struct console_methods *meth = decode_console_type (winsy, ERROR_ME_NOT);
1146 assert (meth);
1147 return (MAYBE_INT_CONTYPE_METH (meth, device_implementation_flags, ())
1148 & XDEVIMPF_PIXEL_GEOMETRY);
1149 }
1150
1151 DEFUN ("domain-device-type", Fdomain_device_type, 0, 1, 0, /*
1152 Return the device type symbol for a DOMAIN, e.g. 'x or 'tty.
1153 DOMAIN can be either a window, frame, device or console.
1154 */
1155 (domain))
1156 {
1157 if (!WINDOWP (domain) && !FRAMEP (domain)
1158 && !DEVICEP (domain) && !CONSOLEP (domain))
1159 signal_simple_error
1160 ("Domain must be either a window, frame, device or console", domain);
1161
1162 return domain_device_type (domain);
1163 }
1164
1165 void
1166 handle_asynch_device_change (void)
1167 {
1168 int i;
1169 int old_asynch_device_change_pending = asynch_device_change_pending;
1170 for (i = 0; i < Dynarr_length (the_console_type_entry_dynarr); i++)
1171 {
1172 if (Dynarr_at (the_console_type_entry_dynarr, i).meths->
1173 asynch_device_change_method)
1174 (Dynarr_at (the_console_type_entry_dynarr, i).meths->
1175 asynch_device_change_method) ();
1176 }
1177 /* reset the flag to 0 unless another notification occurred while
1178 we were processing this one. Block SIGWINCH during this
1179 check to prevent a possible race condition. */
1180 #ifndef WINDOWSNT
1181 EMACS_BLOCK_SIGNAL (SIGWINCH);
1182 #endif
1183 if (old_asynch_device_change_pending == asynch_device_change_pending)
1184 asynch_device_change_pending = 0;
1185 #ifndef WINDOWSNT
1186 EMACS_UNBLOCK_SIGNAL (SIGWINCH);
1187 #endif
1188 }
1189
1190 void
1191 call_critical_lisp_code (struct device *d, Lisp_Object function,
1192 Lisp_Object object)
1193 {
1194 int old_gc_currently_forbidden = gc_currently_forbidden;
1195 Lisp_Object old_inhibit_quit = Vinhibit_quit;
1196
1197 /* There's no reason to bother doing specbinds here, because if
1198 initialize-*-faces signals an error, emacs is going to crash
1199 immediately.
1200 */
1201 gc_currently_forbidden = 1;
1202 Vinhibit_quit = Qt;
1203 LOCK_DEVICE (d);
1204
1205 /* But it's useful to have an error handler; otherwise an infinite
1206 loop may result. */
1207 if (!NILP (object))
1208 call1_with_handler (Qreally_early_error_handler, function, object);
1209 else
1210 call0_with_handler (Qreally_early_error_handler, function);
1211
1212 UNLOCK_DEVICE (d);
1213 Vinhibit_quit = old_inhibit_quit;
1214 gc_currently_forbidden = old_gc_currently_forbidden;
1215 }
1216
1217
1218 /************************************************************************/
1219 /* initialization */
1220 /************************************************************************/
1221
1222 void
1223 syms_of_device (void)
1224 {
1225 DEFSUBR (Fvalid_device_class_p);
1226 DEFSUBR (Fdevice_class_list);
1227
1228 DEFSUBR (Fdfw_device);
1229 DEFSUBR (Fselected_device);
1230 DEFSUBR (Fselect_device);
1231 DEFSUBR (Fset_device_selected_frame);
1232 DEFSUBR (Fdevicep);
1233 DEFSUBR (Fdevice_live_p);
1234 DEFSUBR (Fdevice_name);
1235 DEFSUBR (Fdevice_connection);
1236 DEFSUBR (Fdevice_console);
1237 DEFSUBR (Ffind_device);
1238 DEFSUBR (Fget_device);
1239 DEFSUBR (Fmake_device);
1240 DEFSUBR (Fdelete_device);
1241 DEFSUBR (Fdevice_frame_list);
1242 DEFSUBR (Fdevice_class);
1243 DEFSUBR (Fset_device_class);
1244 DEFSUBR (Fdevice_system_metrics);
1245 DEFSUBR (Fdevice_system_metric);
1246 DEFSUBR (Fset_device_baud_rate);
1247 DEFSUBR (Fdevice_baud_rate);
1248 DEFSUBR (Fdomain_device_type);
1249
1250 defsymbol (&Qdevicep, "devicep");
1251 defsymbol (&Qdevice_live_p, "device-live-p");
1252
1253 defsymbol (&Qcreate_device_hook, "create-device-hook");
1254 defsymbol (&Qdelete_device_hook, "delete-device-hook");
1255
1256 /* Qcolor defined in general.c */
1257 defsymbol (&Qgrayscale, "grayscale");
1258 defsymbol (&Qmono, "mono");
1259
1260 /* Device metrics symbols */
1261 defsymbol (&Qcolor_default, "color-default");
1262 defsymbol (&Qcolor_select, "color-select");
1263 defsymbol (&Qcolor_balloon, "color-balloon");
1264 defsymbol (&Qcolor_3d_face, "color-3d-face");
1265 defsymbol (&Qcolor_3d_light, "color-3d-light");
1266 defsymbol (&Qcolor_3d_dark, "color-3d-dark");
1267 defsymbol (&Qcolor_menu, "color-menu");
1268 defsymbol (&Qcolor_menu_highlight, "color-menu-highlight");
1269 defsymbol (&Qcolor_menu_button, "color-menu-button");
1270 defsymbol (&Qcolor_menu_disabled, "color-menu-disabled");
1271 defsymbol (&Qcolor_toolbar, "color-toolbar");
1272 defsymbol (&Qcolor_scrollbar, "color-scrollbar");
1273 defsymbol (&Qcolor_desktop, "color-desktop");
1274 defsymbol (&Qcolor_workspace, "color-workspace");
1275 defsymbol (&Qfont_default, "font-default");
1276 defsymbol (&Qfont_menubar, "font-menubar");
1277 defsymbol (&Qfont_dialog, "font-dialog");
1278 defsymbol (&Qsize_cursor, "size-cursor");
1279 defsymbol (&Qsize_scrollbar, "size-scrollbar");
1280 defsymbol (&Qsize_menu, "size-menu");
1281 defsymbol (&Qsize_toolbar, "size-toolbar");
1282 defsymbol (&Qsize_toolbar_button, "size-toolbar-button");
1283 defsymbol (&Qsize_toolbar_border, "size-toolbar-border");
1284 defsymbol (&Qsize_icon, "size-icon");
1285 defsymbol (&Qsize_icon_small, "size-icon-small");
1286 defsymbol (&Qsize_device, "size-device");
1287 defsymbol (&Qsize_workspace, "size-workspace");
1288 defsymbol (&Qsize_device_mm, "size-device-mm");
1289 defsymbol (&Qnum_bit_planes, "num-bit-planes");
1290 defsymbol (&Qnum_color_cells, "num-color-cells");
1291 defsymbol (&Qdevice_dpi, "device-dpi");
1292 defsymbol (&Qmouse_buttons, "mouse-buttons");
1293 defsymbol (&Qswap_buttons, "swap-buttons");
1294 defsymbol (&Qshow_sounds, "show-sounds");
1295 defsymbol (&Qslow_device, "slow-device");
1296 defsymbol (&Qsecurity, "security");
1297 }
1298
1299 void
1300 reinit_vars_of_device (void)
1301 {
1302 staticpro_nodump (&Vdefault_device);
1303 Vdefault_device = Qnil;
1304 asynch_device_change_pending = 0;
1305 }
1306
1307 void
1308 vars_of_device (void)
1309 {
1310 reinit_vars_of_device ();
1311
1312 DEFVAR_LISP ("create-device-hook", &Vcreate_device_hook /*
1313 Function or functions to call when a device is created.
1314 One argument, the newly-created device.
1315 This is called after the first frame has been created, but before
1316 calling the `create-frame-hook'.
1317 Note that in general the device will not be selected.
1318 */ );
1319 Vcreate_device_hook = Qnil;
1320
1321 DEFVAR_LISP ("delete-device-hook", &Vdelete_device_hook /*
1322 Function or functions to call when a device is deleted.
1323 One argument, the to-be-deleted device.
1324 */ );
1325 Vdelete_device_hook = Qnil;
1326
1327 Vdevice_class_list = list3 (Qcolor, Qgrayscale, Qmono);
1328 staticpro (&Vdevice_class_list);
1329
1330 /* Death to devices.el !!! */
1331 Fprovide(intern("devices"));
1332 }