Mercurial > emacs

comparison lisp/printing.el @ 90749:900f465c603a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Group together all XEmacs/Emacs definitions.
author Vinicius Jose Latorre <viniciusjl@ig.com.br>
date Mon, 12 Feb 2007 02:16:00 +0000
parents 70100f060860
children f8cc067aba62
comparison
equal deleted inserted replaced
90748:70100f060860 90749:900f465c603a
4 ;; 2006, 2007 Free Software Foundation, Inc. 4 ;; 2006, 2007 Free Software Foundation, Inc.
5 5
6 ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> 6 ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
7 ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> 7 ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
8 ;; Keywords: wp, print, PostScript 8 ;; Keywords: wp, print, PostScript
9 ;; Version: 6.8.4 9 ;; Version: 6.9
10 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre 10 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
11 11
12 (defconst pr-version "6.8.4" 12 (defconst pr-version "6.9"
13 "printing.el, v 6.8.4 <2005/06/11 vinicius> 13 "printing.el, v 6.9 <2007/02/11 vinicius>
14 14
15 Please send all bug fixes and enhancements to 15 Please send all bug fixes and enhancements to
16 Vinicius Jose Latorre <viniciusjl@ig.com.br> 16 Vinicius Jose Latorre <viniciusjl@ig.com.br>
17 ") 17 ")
18 18
1091 file) 1091 file)
1092 ;; Reset the umask. 1092 ;; Reset the umask.
1093 (set-default-file-modes umask))))) 1093 (set-default-file-modes umask)))))
1094 1094
1095 1095
1096 ;; GNU Emacs 1096
1097 (defalias 'pr-e-frame-char-height 'frame-char-height) 1097 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1098 (defalias 'pr-e-frame-char-width 'frame-char-width) 1098 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1099 (defalias 'pr-e-mouse-pixel-position 'mouse-pixel-position) 1099 ;; XEmacs Definitions
1100 ;; XEmacs 1100
1101 (defalias 'pr-x-add-submenu 'add-submenu)
1102 (defalias 'pr-x-event-function 'event-function)
1103 (defalias 'pr-x-event-object 'event-object)
1104 (defalias 'pr-x-find-menu-item 'find-menu-item)
1105 (defalias 'pr-x-font-height 'font-height)
1106 (defalias 'pr-x-font-width 'font-width)
1107 (defalias 'pr-x-get-popup-menu-response 'get-popup-menu-response)
1108 (defalias 'pr-x-make-event 'make-event)
1109 (defalias 'pr-x-misc-user-event-p 'misc-user-event-p)
1110 (defalias 'pr-x-relabel-menu-item 'relabel-menu-item)
1111 (defalias 'pr-x-event-x-pixel 'event-x-pixel)
1112 (defalias 'pr-x-event-y-pixel 'event-y-pixel)
1113 1101
1114 (cond 1102 (cond
1115 ((featurep 'xemacs) ; XEmacs 1103 ((featurep 'xemacs) ; XEmacs
1116 (defvar current-menubar nil) 1104 ;; XEmacs
1117 (defvar current-mouse-event nil)
1118 (defvar zmacs-region-stays nil)
1119 (defalias 'pr-f-set-keymap-parents 'set-keymap-parents) 1105 (defalias 'pr-f-set-keymap-parents 'set-keymap-parents)
1120 (defalias 'pr-f-set-keymap-name 'set-keymap-name) 1106 (defalias 'pr-f-set-keymap-name 'set-keymap-name)
1107
1108 ;; XEmacs
1121 (defun pr-f-read-string (prompt initial history default) 1109 (defun pr-f-read-string (prompt initial history default)
1122 (let ((str (read-string prompt initial))) 1110 (let ((str (read-string prompt initial)))
1123 (if (and str (not (string= str ""))) 1111 (if (and str (not (string= str "")))
1124 str 1112 str
1125 default))) 1113 default)))
1114
1115 ;; XEmacs
1116 (defvar zmacs-region-stays nil)
1117
1118 ;; XEmacs
1126 (defun pr-keep-region-active () 1119 (defun pr-keep-region-active ()
1127 (setq zmacs-region-stays t))) 1120 (setq zmacs-region-stays t))
1128 1121
1122 ;; XEmacs
1123 (defun pr-region-active-p ()
1124 (and pr-auto-region (not zmacs-region-stays) (ps-mark-active-p)))
1125
1126 ;; XEmacs
1127 (defun pr-menu-char-height ()
1128 (font-height (face-font 'default)))
1129
1130 ;; XEmacs
1131 (defun pr-menu-char-width ()
1132 (font-width (face-font 'default)))
1133
1134 ;; XEmacs
1135 (defmacro pr-xemacs-global-menubar (&rest body)
1136 `(save-excursion
1137 (let ((temp (get-buffer-create (make-temp-name " *Temp"))))
1138 ;; be sure to access global menubar
1139 (set-buffer temp)
1140 ,@body
1141 (kill-buffer temp))))
1142
1143 ;; XEmacs
1144 (defun pr-global-menubar (pr-menu-spec)
1145 ;; Menu binding
1146 (pr-xemacs-global-menubar
1147 (add-submenu nil (cons "Printing" pr-menu-spec) "Apps"))
1148 (setq pr-menu-print-item nil))
1149
1150 ;; XEmacs
1151 (defvar current-mouse-event nil)
1152 (defun pr-menu-position (entry index horizontal)
1153 (make-event
1154 'button-release
1155 (list 'button 1
1156 'x (- (event-x-pixel current-mouse-event) ; X
1157 (* horizontal pr-menu-char-width))
1158 'y (- (event-y-pixel current-mouse-event) ; Y
1159 (* (pr-menu-index entry index) pr-menu-char-height)))))
1160
1161 (defvar pr-menu-position nil)
1162 (defvar pr-menu-state nil)
1163
1164 ;; XEmacs
1165 (defvar current-menubar nil) ; to avoid compilation gripes
1166 (defun pr-menu-lookup (path)
1167 (car (find-menu-item current-menubar (cons "Printing" path))))
1168
1169 ;; XEmacs
1170 (defun pr-menu-lock (entry index horizontal state path)
1171 (when pr-menu-lock
1172 (or (and pr-menu-position (eq state pr-menu-state))
1173 (setq pr-menu-position (pr-menu-position entry index horizontal)
1174 pr-menu-state state))
1175 (let* ((menu (pr-menu-lookup path))
1176 (result (get-popup-menu-response menu pr-menu-position)))
1177 (and (misc-user-event-p result)
1178 (funcall (event-function result)
1179 (event-object result))))
1180 (setq pr-menu-position nil)))
1181
1182 ;; XEmacs
1183 (defalias 'pr-update-mode-line 'set-menubar-dirty-flag)
1184
1185 ;; XEmacs
1186 (defvar pr-ps-name-old "PostScript Printers")
1187 (defvar pr-txt-name-old "Text Printers")
1188 (defvar pr-ps-utility-old "PostScript Utility")
1189 (defvar pr-even-or-odd-old "Print All Pages")
1190
1191 ;; XEmacs
1192 (defun pr-do-update-menus (&optional force)
1193 (pr-menu-alist pr-ps-printer-alist
1194 'pr-ps-name
1195 'pr-menu-set-ps-title
1196 '("Printing")
1197 'pr-ps-printer-menu-modified
1198 force
1199 pr-ps-name-old
1200 'postscript 2)
1201 (pr-menu-alist pr-txt-printer-alist
1202 'pr-txt-name
1203 'pr-menu-set-txt-title
1204 '("Printing")
1205 'pr-txt-printer-menu-modified
1206 force
1207 pr-txt-name-old
1208 'text 2)
1209 (let ((save-var pr-ps-utility-menu-modified))
1210 (pr-menu-alist pr-ps-utility-alist
1211 'pr-ps-utility
1212 'pr-menu-set-utility-title
1213 '("Printing" "PostScript Print" "File")
1214 'save-var
1215 force
1216 pr-ps-utility-old
1217 nil 1))
1218 (pr-menu-alist pr-ps-utility-alist
1219 'pr-ps-utility
1220 'pr-menu-set-utility-title
1221 '("Printing" "PostScript Preview" "File")
1222 'pr-ps-utility-menu-modified
1223 force
1224 pr-ps-utility-old
1225 nil 1)
1226 (pr-even-or-odd-pages ps-even-or-odd-pages force))
1227
1228 ;; XEmacs
1229 (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
1230 entry index)
1231 (when (and alist (or force (symbol-value modified-sym)))
1232 (pr-xemacs-global-menubar
1233 (add-submenu menu-path
1234 (pr-menu-create name alist var-sym
1235 fun entry index)))
1236 (funcall fun (symbol-value var-sym))
1237 (set modified-sym nil)))
1238
1239 ;; XEmacs
1240 (defun pr-relabel-menu-item (newname var-sym)
1241 (pr-xemacs-global-menubar
1242 (relabel-menu-item
1243 (list "Printing" (symbol-value var-sym))
1244 newname)
1245 (set var-sym newname)))
1246
1247 ;; XEmacs
1248 (defun pr-menu-set-ps-title (value &optional item entry index)
1249 (pr-relabel-menu-item (format "PostScript Printer: %s" value)
1250 'pr-ps-name-old)
1251 (pr-ps-set-printer value)
1252 (and index
1253 (pr-menu-lock entry index 12 'toggle nil)))
1254
1255 ;; XEmacs
1256 (defun pr-menu-set-txt-title (value &optional item entry index)
1257 (pr-relabel-menu-item (format "Text Printer: %s" value)
1258 'pr-txt-name-old)
1259 (pr-txt-set-printer value)
1260 (and index
1261 (pr-menu-lock entry index 12 'toggle nil)))
1262
1263 ;; XEmacs
1264 (defun pr-menu-set-utility-title (value &optional item entry index)
1265 (pr-xemacs-global-menubar
1266 (let ((newname (format "%s" value)))
1267 (relabel-menu-item
1268 (list "Printing" "PostScript Print" "File" pr-ps-utility-old)
1269 newname)
1270 (relabel-menu-item
1271 (list "Printing" "PostScript Preview" "File" pr-ps-utility-old)
1272 newname)
1273 (setq pr-ps-utility-old newname)))
1274 (pr-ps-set-utility value)
1275 (and index
1276 (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
1277
1278 ;; XEmacs
1279 (defun pr-even-or-odd-pages (value &optional no-lock)
1280 (pr-relabel-menu-item (cdr (assq value pr-even-or-odd-alist))
1281 'pr-even-or-odd-old)
1282 (setq ps-even-or-odd-pages value)
1283 (or no-lock
1284 (pr-menu-lock 'postscript-options 8 12 'toggle nil)))
1285
1286 )
1287 (t ; emacs
1288 ;; Do nothing
1289 )) ; end cond featurep
1290
1291
1292
1293 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1294 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1295 ;; Emacs Definitions
1296
1297
1298 (cond
1299 ((featurep 'xemacs) ; XEmacs
1300 ;; Do nothing
1301 )
1129 (t ; GNU Emacs 1302 (t ; GNU Emacs
1130 (defvar deactivate-mark nil) 1303 ;; GNU Emacs
1131 (defalias 'pr-f-set-keymap-parents 'set-keymap-parent) 1304 (defalias 'pr-f-set-keymap-parents 'set-keymap-parent)
1132 (defalias 'pr-f-set-keymap-name 'ignore) 1305 (defalias 'pr-f-set-keymap-name 'ignore)
1133 (defalias 'pr-f-read-string 'read-string) 1306 (defalias 'pr-f-read-string 'read-string)
1307
1308 ;; GNU Emacs
1309 (defvar deactivate-mark nil)
1310
1311 ;; GNU Emacs
1134 (defun pr-keep-region-active () 1312 (defun pr-keep-region-active ()
1135 (setq deactivate-mark nil)))) 1313 (setq deactivate-mark nil))
1314
1315 ;; GNU Emacs
1316 (defun pr-region-active-p ()
1317 (and pr-auto-region transient-mark-mode mark-active))
1318
1319 ;; GNU Emacs
1320 (defun pr-menu-char-height ()
1321 (frame-char-height))
1322
1323 ;; GNU Emacs
1324 (defun pr-menu-char-width ()
1325 (frame-char-width))
1326
1327 ;; GNU Emacs
1328 ;; Menu binding
1329 (require 'easymenu)
1330 ;; Replace existing "print" item by "Printing" item.
1331 ;; If you're changing this file, you'll load it a second,
1332 ;; third... time, but "print" item exists only in the first load.
1333 (eval-and-compile
1334 (cond
1335 ;; Emacs 20
1336 ((< emacs-major-version 21)
1337 (defun pr-global-menubar (pr-menu-spec)
1338 (easy-menu-change '("tools") "Printing" pr-menu-spec pr-menu-print-item)
1339 (when pr-menu-print-item
1340 (easy-menu-remove-item nil '("tools") pr-menu-print-item)
1341 (setq pr-menu-print-item nil
1342 pr-menu-bar (vector 'menu-bar 'tools
1343 (pr-get-symbol "Printing")))))
1344 )
1345 ;; Emacs 21 & 22
1346 (t
1347 (defun pr-global-menubar (pr-menu-spec)
1348 (let ((menu-file (if (= emacs-major-version 21)
1349 '("menu-bar" "files") ; Emacs 21
1350 '("menu-bar" "file")))) ; Emacs 22 or higher
1351 (cond
1352 (pr-menu-print-item
1353 (easy-menu-add-item global-map menu-file
1354 (easy-menu-create-menu "Print" pr-menu-spec)
1355 "print-buffer")
1356 (dolist (item '("print-buffer" "print-region"
1357 "ps-print-buffer-faces" "ps-print-region-faces"
1358 "ps-print-buffer" "ps-print-region"))
1359 (easy-menu-remove-item global-map menu-file item))
1360 (setq pr-menu-print-item nil
1361 pr-menu-bar (vector 'menu-bar
1362 (pr-get-symbol (nth 1 menu-file))
1363 (pr-get-symbol "Print"))))
1364 (t
1365 (easy-menu-add-item global-map menu-file
1366 (easy-menu-create-menu "Print" pr-menu-spec)))
1367 )))
1368 )))
1369
1370 (eval-and-compile
1371 (cond
1372 (ps-windows-system
1373 ;; GNU Emacs for Windows 9x/NT
1374 (defun pr-menu-position (entry index horizontal)
1375 (let ((pos (cdr (mouse-pixel-position))))
1376 (list
1377 (list (or (car pos) 0) ; X
1378 (- (or (cdr pos) 0) ; Y
1379 (* (pr-menu-index entry index) pr-menu-char-height)))
1380 (selected-frame)))) ; frame
1381 )
1382 (t
1383 ;; GNU Emacs
1384 (defun pr-menu-position (entry index horizontal)
1385 (let ((pos (cdr (mouse-pixel-position))))
1386 (list
1387 (list (- (or (car pos) 0) ; X
1388 (* horizontal pr-menu-char-width))
1389 (- (or (cdr pos) 0) ; Y
1390 (* (pr-menu-index entry index) pr-menu-char-height)))
1391 (selected-frame)))) ; frame
1392 )))
1393
1394 (defvar pr-menu-position nil)
1395 (defvar pr-menu-state nil)
1396
1397 ;; GNU Emacs
1398 (defun pr-menu-lookup (path)
1399 (lookup-key global-map
1400 (if path
1401 (vconcat pr-menu-bar
1402 (mapcar 'pr-get-symbol
1403 (if (listp path)
1404 path
1405 (list path))))
1406 pr-menu-bar)))
1407
1408 ;; GNU Emacs
1409 (defun pr-menu-lock (entry index horizontal state path)
1410 (when pr-menu-lock
1411 (or (and pr-menu-position (eq state pr-menu-state))
1412 (setq pr-menu-position (pr-menu-position entry index horizontal)
1413 pr-menu-state state))
1414 (let* ((menu (pr-menu-lookup path))
1415 (result (x-popup-menu pr-menu-position menu)))
1416 (and result
1417 (let ((command (lookup-key menu (vconcat result))))
1418 (if (fboundp command)
1419 (funcall command)
1420 (eval command)))))
1421 (setq pr-menu-position nil)))
1422
1423 ;; GNU Emacs
1424 (defalias 'pr-update-mode-line 'force-mode-line-update)
1425
1426 ;; GNU Emacs
1427 (defun pr-do-update-menus (&optional force)
1428 (pr-menu-alist pr-ps-printer-alist
1429 'pr-ps-name
1430 'pr-menu-set-ps-title
1431 "PostScript Printers"
1432 'pr-ps-printer-menu-modified
1433 force
1434 "PostScript Printers"
1435 'postscript 2)
1436 (pr-menu-alist pr-txt-printer-alist
1437 'pr-txt-name
1438 'pr-menu-set-txt-title
1439 "Text Printers"
1440 'pr-txt-printer-menu-modified
1441 force
1442 "Text Printers"
1443 'text 2)
1444 (let ((save-var pr-ps-utility-menu-modified))
1445 (pr-menu-alist pr-ps-utility-alist
1446 'pr-ps-utility
1447 'pr-menu-set-utility-title
1448 '("PostScript Print" "File" "PostScript Utility")
1449 'save-var
1450 force
1451 "PostScript Utility"
1452 nil 1))
1453 (pr-menu-alist pr-ps-utility-alist
1454 'pr-ps-utility
1455 'pr-menu-set-utility-title
1456 '("PostScript Preview" "File" "PostScript Utility")
1457 'pr-ps-utility-menu-modified
1458 force
1459 "PostScript Utility"
1460 nil 1)
1461 (pr-even-or-odd-pages ps-even-or-odd-pages force))
1462
1463 ;; GNU Emacs
1464 (defun pr-menu-get-item (name-list)
1465 ;; NAME-LIST is a string or a list of strings.
1466 (or (listp name-list)
1467 (setq name-list (list name-list)))
1468 (and name-list
1469 (let* ((reversed (reverse name-list))
1470 (name (pr-get-symbol (car reversed)))
1471 (path (nreverse (cdr reversed)))
1472 (menu (lookup-key
1473 global-map
1474 (vconcat pr-menu-bar
1475 (mapcar 'pr-get-symbol path)))))
1476 (assq name (nthcdr 2 menu)))))
1477
1478 ;; GNU Emacs
1479 (defvar pr-temp-menu nil)
1480
1481 ;; GNU Emacs
1482 (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
1483 entry index)
1484 (when (and alist (or force (symbol-value modified-sym)))
1485 (easy-menu-define pr-temp-menu nil ""
1486 (pr-menu-create name alist var-sym fun entry index))
1487 (let ((item (pr-menu-get-item menu-path)))
1488 (and item
1489 (let* ((binding (nthcdr 3 item))
1490 (key-binding (cdr binding)))
1491 (setcar binding pr-temp-menu)
1492 (and key-binding (listp (car key-binding))
1493 (setcdr binding (cdr key-binding))) ; skip KEY-BINDING
1494 (funcall fun (symbol-value var-sym) item))))
1495 (set modified-sym nil)))
1496
1497 ;; GNU Emacs
1498 (defun pr-menu-set-item-name (item name)
1499 (and item
1500 (setcar (nthcdr 2 item) name))) ; ITEM-NAME
1501
1502 ;; GNU Emacs
1503 (defun pr-menu-set-ps-title (value &optional item entry index)
1504 (pr-menu-set-item-name (or item
1505 (pr-menu-get-item "PostScript Printers"))
1506 (format "PostScript Printer: %s" value))
1507 (pr-ps-set-printer value)
1508 (and index
1509 (pr-menu-lock entry index 12 'toggle nil)))
1510
1511 ;; GNU Emacs
1512 (defun pr-menu-set-txt-title (value &optional item entry index)
1513 (pr-menu-set-item-name (or item
1514 (pr-menu-get-item "Text Printers"))
1515 (format "Text Printer: %s" value))
1516 (pr-txt-set-printer value)
1517 (and index
1518 (pr-menu-lock entry index 12 'toggle nil)))
1519
1520 ;; GNU Emacs
1521 (defun pr-menu-set-utility-title (value &optional item entry index)
1522 (let ((name (symbol-name value)))
1523 (if item
1524 (pr-menu-set-item-name item name)
1525 (pr-menu-set-item-name
1526 (pr-menu-get-item
1527 '("PostScript Print" "File" "PostScript Utility"))
1528 name)
1529 (pr-menu-set-item-name
1530 (pr-menu-get-item
1531 '("PostScript Preview" "File" "PostScript Utility"))
1532 name)))
1533 (pr-ps-set-utility value)
1534 (and index
1535 (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
1536
1537 ;; GNU Emacs
1538 (defun pr-even-or-odd-pages (value &optional no-lock)
1539 (pr-menu-set-item-name (pr-menu-get-item "Print All Pages")
1540 (cdr (assq value pr-even-or-odd-alist)))
1541 (setq ps-even-or-odd-pages value)
1542 (or no-lock
1543 (pr-menu-lock 'postscript-options 8 12 'toggle nil)))
1544
1545 )) ; end cond featurep
1136 1546
1137 1547
1138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1139 ;; Customization Functions 1549 ;; Customization Functions
1140 1550
2450 :type 'boolean 2860 :type 'boolean
2451 :version "20" 2861 :version "20"
2452 :group 'printing) 2862 :group 'printing)
2453 2863
2454 2864
2455 (defcustom pr-menu-char-height 2865 (defcustom pr-menu-char-height (pr-menu-char-height)
2456 (cond ((featurep 'xemacs) ; XEmacs
2457 (pr-x-font-height (face-font 'default)))
2458 (t ; GNU Emacs
2459 (pr-e-frame-char-height)))
2460 "*Specify menu char height in pixels. 2866 "*Specify menu char height in pixels.
2461 2867
2462 This variable is used to guess which vertical position should be locked the 2868 This variable is used to guess which vertical position should be locked the
2463 menu, so don't forget to adjust it if menu position is not ok. 2869 menu, so don't forget to adjust it if menu position is not ok.
2464 2870
2466 :type 'integer 2872 :type 'integer
2467 :version "20" 2873 :version "20"
2468 :group 'printing) 2874 :group 'printing)
2469 2875
2470 2876
2471 (defcustom pr-menu-char-width 2877 (defcustom pr-menu-char-width (pr-menu-char-width)
2472 (cond ((featurep 'xemacs) ; XEmacs
2473 (pr-x-font-width (face-font 'default)))
2474 (t ; GNU Emacs
2475 (pr-e-frame-char-width)))
2476 "*Specify menu char width in pixels. 2878 "*Specify menu char width in pixels.
2477 2879
2478 This variable is used to guess which horizontal position should be locked the 2880 This variable is used to guess which horizontal position should be locked the
2479 menu, so don't forget to adjust it if menu position is not ok. 2881 menu, so don't forget to adjust it if menu position is not ok.
2480 2882
2770 3172
2771 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2772 ;; Keys & Menus 3174 ;; Keys & Menus
2773 3175
2774 3176
2775 (defmacro pr-xemacs-global-menubar (&rest body)
2776 `(save-excursion
2777 (let ((temp (get-buffer-create (make-temp-name " *Temp"))))
2778 ;; be sure to access global menubar
2779 (set-buffer temp)
2780 ,@body
2781 (kill-buffer temp))))
2782
2783
2784 (defsubst pr-visible-p (key) 3177 (defsubst pr-visible-p (key)
2785 (memq key pr-visible-entry-list)) 3178 (memq key pr-visible-entry-list))
2786 3179
2787 3180
2788 (defsubst pr-mode-alist-p () 3181 (defsubst pr-mode-alist-p ()
2799 3192
2800 (defalias 'pr-get-symbol 3193 (defalias 'pr-get-symbol
2801 (if (fboundp 'easy-menu-intern) ; hacked from easymenu.el 3194 (if (fboundp 'easy-menu-intern) ; hacked from easymenu.el
2802 'easy-menu-intern 3195 'easy-menu-intern
2803 (lambda (s) (if (stringp s) (intern s) s)))) 3196 (lambda (s) (if (stringp s) (intern s) s))))
2804
2805 (cond
2806 ((featurep 'xemacs) ; XEmacs
2807 (defvar zmacs-region-stays nil) ; to avoid compilation gripes
2808 (defun pr-region-active-p ()
2809 (and pr-auto-region (not zmacs-region-stays) (ps-mark-active-p))))
2810
2811 (t ; GNU Emacs
2812 (defun pr-region-active-p ()
2813 (and pr-auto-region transient-mark-mode mark-active))))
2814 3197
2815 3198
2816 (defconst pr-menu-spec 3199 (defconst pr-menu-spec
2817 ;; Menu mapping: 3200 ;; Menu mapping:
2818 ;; unfortunately XEmacs doesn't support :active for submenus, 3201 ;; unfortunately XEmacs doesn't support :active for submenus,
3068 On Emacs 21 and 22, it replaces the File/Print* menu entries by File/Print 3451 On Emacs 21 and 22, it replaces the File/Print* menu entries by File/Print
3069 menu. 3452 menu.
3070 3453
3071 Calls `pr-update-menus' to adjust menus." 3454 Calls `pr-update-menus' to adjust menus."
3072 (interactive) 3455 (interactive)
3073 (cond 3456 (pr-global-menubar pr-menu-spec)
3074 ((featurep 'xemacs) ; XEmacs
3075 ;; Menu binding
3076 (pr-xemacs-global-menubar
3077 (pr-x-add-submenu nil (cons "Printing" pr-menu-spec) "Apps"))
3078 (setq pr-menu-print-item nil))
3079
3080
3081 (t ; GNU Emacs
3082 ;; Menu binding
3083 (require 'easymenu)
3084 ;; Replace existing "print" item by "Printing" item.
3085 ;; If you're changing this file, you'll load it a second,
3086 ;; third... time, but "print" item exists only in the first load.
3087 (cond
3088 ;; Emacs 20
3089 ((< emacs-major-version 21)
3090 (easy-menu-change '("tools") "Printing" pr-menu-spec pr-menu-print-item)
3091 (when pr-menu-print-item
3092 (easy-menu-remove-item nil '("tools") pr-menu-print-item)
3093 (setq pr-menu-print-item nil
3094 pr-menu-bar (vector 'menu-bar 'tools
3095 (pr-get-symbol "Printing")))))
3096 ;; Emacs 21 & 22
3097 (t
3098 (let ((menu-file (if (= emacs-major-version 21)
3099 '("menu-bar" "files") ; Emacs 21
3100 '("menu-bar" "file")))) ; Emacs 22 or higher
3101 (cond
3102 (pr-menu-print-item
3103 (easy-menu-add-item global-map menu-file
3104 (easy-menu-create-menu "Print" pr-menu-spec)
3105 "print-buffer")
3106 (dolist (item '("print-buffer" "print-region"
3107 "ps-print-buffer-faces" "ps-print-region-faces"
3108 "ps-print-buffer" "ps-print-region"))
3109 (easy-menu-remove-item global-map menu-file item))
3110 (setq pr-menu-print-item nil
3111 pr-menu-bar (vector 'menu-bar
3112 (pr-get-symbol (nth 1 menu-file))
3113 (pr-get-symbol "Print"))))
3114 (t
3115 (easy-menu-add-item global-map menu-file
3116 (easy-menu-create-menu "Print" pr-menu-spec)))
3117 ))))))
3118 (pr-update-menus t)) 3457 (pr-update-menus t))
3119 3458
3120 3459
3121 ;; Key binding 3460 ;; Key binding
3122 (let ((pr-print-key (if (featurep 'xemacs) 3461 (let ((pr-print-key (if (featurep 'xemacs)
4839 (setq index (+ index 5178 (setq index (+ index
4840 (cdr (assq key pr-menu-entry-alist))))))) 5179 (cdr (assq key pr-menu-entry-alist)))))))
4841 (+ index 2)) 5180 (+ index 2))
4842 5181
4843 5182
4844 (defvar pr-menu-position nil)
4845 (defvar pr-menu-state nil)
4846
4847
4848 (cond
4849 ((featurep 'xemacs)
4850 ;; XEmacs
4851 (defvar current-mouse-event nil) ; to avoid compilation gripes
4852 (defun pr-menu-position (entry index horizontal)
4853 (pr-x-make-event
4854 'button-release
4855 (list 'button 1
4856 'x (- (pr-x-event-x-pixel current-mouse-event) ; X
4857 (* horizontal pr-menu-char-width))
4858 'y (- (pr-x-event-y-pixel current-mouse-event) ; Y
4859 (* (pr-menu-index entry index) pr-menu-char-height)))))
4860 )
4861 (ps-windows-system
4862 ;; GNU Emacs for Windows 9x/NT
4863 (defun pr-menu-position (entry index horizontal)
4864 (let ((pos (cdr (pr-e-mouse-pixel-position))))
4865 (list
4866 (list (or (car pos) 0) ; X
4867 (- (or (cdr pos) 0) ; Y
4868 (* (pr-menu-index entry index) pr-menu-char-height)))
4869 (selected-frame)))) ; frame
4870 )
4871 (t
4872 ;; GNU Emacs
4873 (defun pr-menu-position (entry index horizontal)
4874 (let ((pos (cdr (pr-e-mouse-pixel-position))))
4875 (list
4876 (list (- (or (car pos) 0) ; X
4877 (* horizontal pr-menu-char-width))
4878 (- (or (cdr pos) 0) ; Y
4879 (* (pr-menu-index entry index) pr-menu-char-height)))
4880 (selected-frame)))) ; frame
4881 ))
4882
4883 (cond
4884 ((featurep 'xemacs)
4885 ;; XEmacs
4886 (defvar current-menubar nil) ; to avoid compilation gripes
4887 (defun pr-menu-lookup (path)
4888 (car (pr-x-find-menu-item current-menubar (cons "Printing" path))))
4889
4890 ;; XEmacs
4891 (defun pr-menu-lock (entry index horizontal state path)
4892 (when pr-menu-lock
4893 (or (and pr-menu-position (eq state pr-menu-state))
4894 (setq pr-menu-position (pr-menu-position entry index horizontal)
4895 pr-menu-state state))
4896 (let* ((menu (pr-menu-lookup path))
4897 (result (pr-x-get-popup-menu-response menu pr-menu-position)))
4898 (and (pr-x-misc-user-event-p result)
4899 (funcall (pr-x-event-function result)
4900 (pr-x-event-object result))))
4901 (setq pr-menu-position nil))))
4902
4903
4904 (t
4905 ;; GNU Emacs
4906 (defun pr-menu-lookup (path)
4907 (lookup-key global-map
4908 (if path
4909 (vconcat pr-menu-bar
4910 (mapcar 'pr-get-symbol
4911 (if (listp path)
4912 path
4913 (list path))))
4914 pr-menu-bar)))
4915
4916 ;; GNU Emacs
4917 (defun pr-menu-lock (entry index horizontal state path)
4918 (when pr-menu-lock
4919 (or (and pr-menu-position (eq state pr-menu-state))
4920 (setq pr-menu-position (pr-menu-position entry index horizontal)
4921 pr-menu-state state))
4922 (let* ((menu (pr-menu-lookup path))
4923 (result (x-popup-menu pr-menu-position menu)))
4924 (and result
4925 (let ((command (lookup-key menu (vconcat result))))
4926 (if (fboundp command)
4927 (funcall command)
4928 (eval command)))))
4929 (setq pr-menu-position nil)))))
4930
4931
4932 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5183 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4933 ;; Printer & Utility Selection 5184 ;; Printer & Utility Selection
4934 5185
4935 5186
4936 (defun pr-update-var (var-sym alist) 5187 (defun pr-update-var (var-sym alist)
4987 (symbol-name sym) 5238 (symbol-name sym)
4988 (list fun (list 'quote sym) nil (list 'quote entry) index) 5239 (list fun (list 'quote sym) nil (list 'quote entry) index)
4989 :style 'radio 5240 :style 'radio
4990 :selected (list 'eq var-sym (list 'quote sym))))) 5241 :selected (list 'eq var-sym (list 'quote sym)))))
4991 alist))) 5242 alist)))
4992
4993
4994 (cond
4995 ((featurep 'xemacs)
4996 ;; XEmacs
4997 (defalias 'pr-update-mode-line 'set-menubar-dirty-flag)
4998
4999 ;; XEmacs
5000 (defvar pr-ps-name-old "PostScript Printers")
5001 (defvar pr-txt-name-old "Text Printers")
5002 (defvar pr-ps-utility-old "PostScript Utility")
5003 (defvar pr-even-or-odd-old "Print All Pages")
5004
5005 ;; XEmacs
5006 (defun pr-do-update-menus (&optional force)
5007 (pr-menu-alist pr-ps-printer-alist
5008 'pr-ps-name
5009 'pr-menu-set-ps-title
5010 '("Printing")
5011 'pr-ps-printer-menu-modified
5012 force
5013 pr-ps-name-old
5014 'postscript 2)
5015 (pr-menu-alist pr-txt-printer-alist
5016 'pr-txt-name
5017 'pr-menu-set-txt-title
5018 '("Printing")
5019 'pr-txt-printer-menu-modified
5020 force
5021 pr-txt-name-old
5022 'text 2)
5023 (let ((save-var pr-ps-utility-menu-modified))
5024 (pr-menu-alist pr-ps-utility-alist
5025 'pr-ps-utility
5026 'pr-menu-set-utility-title
5027 '("Printing" "PostScript Print" "File")
5028 'save-var
5029 force
5030 pr-ps-utility-old
5031 nil 1))
5032 (pr-menu-alist pr-ps-utility-alist
5033 'pr-ps-utility
5034 'pr-menu-set-utility-title
5035 '("Printing" "PostScript Preview" "File")
5036 'pr-ps-utility-menu-modified
5037 force
5038 pr-ps-utility-old
5039 nil 1)
5040 (pr-even-or-odd-pages ps-even-or-odd-pages force))
5041
5042 ;; XEmacs
5043 (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
5044 entry index)
5045 (when (and alist (or force (symbol-value modified-sym)))
5046 (pr-xemacs-global-menubar
5047 (pr-x-add-submenu menu-path
5048 (pr-menu-create name alist var-sym
5049 fun entry index)))
5050 (funcall fun (symbol-value var-sym))
5051 (set modified-sym nil)))
5052
5053 ;; XEmacs
5054 (defun pr-relabel-menu-item (newname var-sym)
5055 (pr-xemacs-global-menubar
5056 (pr-x-relabel-menu-item
5057 (list "Printing" (symbol-value var-sym))
5058 newname)
5059 (set var-sym newname)))
5060
5061 ;; XEmacs
5062 (defun pr-menu-set-ps-title (value &optional item entry index)
5063 (pr-relabel-menu-item (format "PostScript Printer: %s" value)
5064 'pr-ps-name-old)
5065 (pr-ps-set-printer value)
5066 (and index
5067 (pr-menu-lock entry index 12 'toggle nil)))
5068
5069 ;; XEmacs
5070 (defun pr-menu-set-txt-title (value &optional item entry index)
5071 (pr-relabel-menu-item (format "Text Printer: %s" value)
5072 'pr-txt-name-old)
5073 (pr-txt-set-printer value)
5074 (and index
5075 (pr-menu-lock entry index 12 'toggle nil)))
5076
5077 ;; XEmacs
5078 (defun pr-menu-set-utility-title (value &optional item entry index)
5079 (pr-xemacs-global-menubar
5080 (let ((newname (format "%s" value)))
5081 (pr-x-relabel-menu-item
5082 (list "Printing" "PostScript Print" "File" pr-ps-utility-old)
5083 newname)
5084 (pr-x-relabel-menu-item
5085 (list "Printing" "PostScript Preview" "File" pr-ps-utility-old)
5086 newname)
5087 (setq pr-ps-utility-old newname)))
5088 (pr-ps-set-utility value)
5089 (and index
5090 (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
5091
5092 ;; XEmacs
5093 (defun pr-even-or-odd-pages (value &optional no-lock)
5094 (pr-relabel-menu-item (cdr (assq value pr-even-or-odd-alist))
5095 'pr-even-or-odd-old)
5096 (setq ps-even-or-odd-pages value)
5097 (or no-lock
5098 (pr-menu-lock 'postscript-options 8 12 'toggle nil))))
5099
5100
5101 (t
5102 ;; GNU Emacs
5103 (defalias 'pr-update-mode-line 'force-mode-line-update)
5104
5105 ;; GNU Emacs
5106 (defun pr-do-update-menus (&optional force)
5107 (pr-menu-alist pr-ps-printer-alist
5108 'pr-ps-name
5109 'pr-menu-set-ps-title
5110 "PostScript Printers"
5111 'pr-ps-printer-menu-modified
5112 force
5113 "PostScript Printers"
5114 'postscript 2)
5115 (pr-menu-alist pr-txt-printer-alist
5116 'pr-txt-name
5117 'pr-menu-set-txt-title
5118 "Text Printers"
5119 'pr-txt-printer-menu-modified
5120 force
5121 "Text Printers"
5122 'text 2)
5123 (let ((save-var pr-ps-utility-menu-modified))
5124 (pr-menu-alist pr-ps-utility-alist
5125 'pr-ps-utility
5126 'pr-menu-set-utility-title
5127 '("PostScript Print" "File" "PostScript Utility")
5128 'save-var
5129 force
5130 "PostScript Utility"
5131 nil 1))
5132 (pr-menu-alist pr-ps-utility-alist
5133 'pr-ps-utility
5134 'pr-menu-set-utility-title
5135 '("PostScript Preview" "File" "PostScript Utility")
5136 'pr-ps-utility-menu-modified
5137 force
5138 "PostScript Utility"
5139 nil 1)
5140 (pr-even-or-odd-pages ps-even-or-odd-pages force))
5141
5142 ;; GNU Emacs
5143 (defun pr-menu-get-item (name-list)
5144 ;; NAME-LIST is a string or a list of strings.
5145 (or (listp name-list)
5146 (setq name-list (list name-list)))
5147 (and name-list
5148 (let* ((reversed (reverse name-list))
5149 (name (pr-get-symbol (car reversed)))
5150 (path (nreverse (cdr reversed)))
5151 (menu (lookup-key
5152 global-map
5153 (vconcat pr-menu-bar
5154 (mapcar 'pr-get-symbol path)))))
5155 (assq name (nthcdr 2 menu)))))
5156
5157 ;; GNU Emacs
5158 (defvar pr-temp-menu nil)
5159
5160 ;; GNU Emacs
5161 (defun pr-menu-alist (alist var-sym fun menu-path modified-sym force name
5162 entry index)
5163 (when (and alist (or force (symbol-value modified-sym)))
5164 (easy-menu-define pr-temp-menu nil ""
5165 (pr-menu-create name alist var-sym fun entry index))
5166 (let ((item (pr-menu-get-item menu-path)))
5167 (and item
5168 (let* ((binding (nthcdr 3 item))
5169 (key-binding (cdr binding)))
5170 (setcar binding pr-temp-menu)
5171 (and key-binding (listp (car key-binding))
5172 (setcdr binding (cdr key-binding))) ; skip KEY-BINDING
5173 (funcall fun (symbol-value var-sym) item))))
5174 (set modified-sym nil)))
5175
5176 ;; GNU Emacs
5177 (defun pr-menu-set-item-name (item name)
5178 (and item
5179 (setcar (nthcdr 2 item) name))) ; ITEM-NAME
5180
5181 ;; GNU Emacs
5182 (defun pr-menu-set-ps-title (value &optional item entry index)
5183 (pr-menu-set-item-name (or item
5184 (pr-menu-get-item "PostScript Printers"))
5185 (format "PostScript Printer: %s" value))
5186 (pr-ps-set-printer value)
5187 (and index
5188 (pr-menu-lock entry index 12 'toggle nil)))
5189
5190 ;; GNU Emacs
5191 (defun pr-menu-set-txt-title (value &optional item entry index)
5192 (pr-menu-set-item-name (or item
5193 (pr-menu-get-item "Text Printers"))
5194 (format "Text Printer: %s" value))
5195 (pr-txt-set-printer value)
5196 (and index
5197 (pr-menu-lock entry index 12 'toggle nil)))
5198
5199 ;; GNU Emacs
5200 (defun pr-menu-set-utility-title (value &optional item entry index)
5201 (let ((name (symbol-name value)))
5202 (if item
5203 (pr-menu-set-item-name item name)
5204 (pr-menu-set-item-name
5205 (pr-menu-get-item
5206 '("PostScript Print" "File" "PostScript Utility"))
5207 name)
5208 (pr-menu-set-item-name
5209 (pr-menu-get-item
5210 '("PostScript Preview" "File" "PostScript Utility"))
5211 name)))
5212 (pr-ps-set-utility value)
5213 (and index
5214 (pr-menu-lock entry index 5 nil '("PostScript Print" "File"))))
5215
5216 ;; GNU Emacs
5217 (defun pr-even-or-odd-pages (value &optional no-lock)
5218 (pr-menu-set-item-name (pr-menu-get-item "Print All Pages")
5219 (cdr (assq value pr-even-or-odd-alist)))
5220 (setq ps-even-or-odd-pages value)
5221 (or no-lock
5222 (pr-menu-lock 'postscript-options 8 12 'toggle nil)))))
5223 5243
5224 5244
5225 (defun pr-ps-set-utility (value) 5245 (defun pr-ps-set-utility (value)
5226 (let ((item (cdr (assq value pr-ps-utility-alist)))) 5246 (let ((item (cdr (assq value pr-ps-utility-alist))))
5227 (or item 5247 (or item