| 1100 | | (let ((movement (eq (get this-command 'CUA) 'move))) |
|---|
| 1101 | | |
|---|
| 1102 | | ;; Cancel prefix key timeout if user enters another key. |
|---|
| 1103 | | (when cua--prefix-override-timer |
|---|
| 1104 | | (if (timerp cua--prefix-override-timer) |
|---|
| 1105 | | (cancel-timer cua--prefix-override-timer)) |
|---|
| 1106 | | (setq cua--prefix-override-timer nil)) |
|---|
| 1107 | | |
|---|
| 1108 | | ;; Handle shifted cursor keys and other movement commands. |
|---|
| 1109 | | ;; If region is not active, region is activated if key is shifted. |
|---|
| 1110 | | ;; If region is active, region is cancelled if key is unshifted (and region not started with C-SPC). |
|---|
| 1111 | | ;; If rectangle is active, expand rectangle in specified direction and ignore the movement. |
|---|
| 1112 | | (if movement |
|---|
| 1113 | | (cond |
|---|
| 1114 | | ((if window-system |
|---|
| 1115 | | (memq 'shift (event-modifiers |
|---|
| 1116 | | (aref (this-single-command-raw-keys) 0))) |
|---|
| 1117 | | (or |
|---|
| 1118 | | (memq 'shift (event-modifiers |
|---|
| 1119 | | (aref (this-single-command-keys) 0))) |
|---|
| 1120 | | ;; See if raw escape sequence maps to a shifted event, e.g. S-up or C-S-home. |
|---|
| 1121 | | (and (boundp 'function-key-map) |
|---|
| 1122 | | function-key-map |
|---|
| 1123 | | (let ((ev (lookup-key function-key-map |
|---|
| 1124 | | (this-single-command-raw-keys)))) |
|---|
| 1125 | | (and (vector ev) |
|---|
| 1126 | | (symbolp (setq ev (aref ev 0))) |
|---|
| 1127 | | (string-match "S-" (symbol-name ev))))))) |
|---|
| 1128 | | (unless mark-active |
|---|
| 1129 | | (push-mark-command nil t)) |
|---|
| 1130 | | (setq cua--last-region-shifted t) |
|---|
| 1131 | | (setq cua--explicit-region-start nil)) |
|---|
| 1132 | | ((or cua--explicit-region-start cua--rectangle) |
|---|
| 1133 | | (unless mark-active |
|---|
| 1134 | | (push-mark-command nil nil))) |
|---|
| 1135 | | (t |
|---|
| 1136 | | ;; If we set mark-active to nil here, the region highlight will not be |
|---|
| 1137 | | ;; removed by the direct_output_ commands. |
|---|
| 1138 | | (setq deactivate-mark t))) |
|---|
| 1139 | | |
|---|
| 1140 | | ;; Handle delete-selection property on other commands |
|---|
| 1141 | | (if (and mark-active (not deactivate-mark)) |
|---|
| 1142 | | (let* ((ds (or (get this-command 'delete-selection) |
|---|
| 1143 | | (get this-command 'pending-delete))) |
|---|
| 1144 | | (nc (cond |
|---|
| 1145 | | ((not ds) nil) |
|---|
| 1146 | | ((eq ds 'yank) |
|---|
| 1147 | | 'cua-paste) |
|---|
| 1148 | | ((eq ds 'kill) |
|---|
| 1149 | | (if cua--rectangle |
|---|
| 1150 | | 'cua-copy-rectangle |
|---|
| 1151 | | 'cua-copy-region)) |
|---|
| 1152 | | ((eq ds 'supersede) |
|---|
| 1153 | | (if cua--rectangle |
|---|
| 1154 | | 'cua-delete-rectangle |
|---|
| 1155 | | 'cua-delete-region)) |
|---|
| 1156 | | (t |
|---|
| 1157 | | (if cua--rectangle |
|---|
| 1158 | | 'cua-delete-rectangle ;; replace? |
|---|
| 1159 | | 'cua-replace-region))))) |
|---|
| 1160 | | (if nc |
|---|
| 1161 | | (setq this-original-command this-command |
|---|
| 1162 | | this-command nc))))) |
|---|
| 1163 | | |
|---|
| 1164 | | ;; Detect extension of rectangles by mouse or other movement |
|---|
| 1165 | | (setq cua--buffer-and-point-before-command |
|---|
| 1166 | | (if cua--rectangle (cons (current-buffer) (point)))))) |
|---|
| | 1100 | ;; Cancel prefix key timeout if user enters another key. |
|---|
| | 1101 | (when cua--prefix-override-timer |
|---|
| | 1102 | (if (timerp cua--prefix-override-timer) |
|---|
| | 1103 | (cancel-timer cua--prefix-override-timer)) |
|---|
| | 1104 | (setq cua--prefix-override-timer nil)) |
|---|
| | 1105 | |
|---|
| | 1106 | (cond |
|---|
| | 1107 | ;; Only symbol commands can have necessary properties |
|---|
| | 1108 | ((not (symbolp this-command)) |
|---|
| | 1109 | nil) |
|---|
| | 1110 | |
|---|
| | 1111 | ;; Handle delete-selection property on non-movement commands |
|---|
| | 1112 | ((not (eq (get this-command 'CUA) 'move)) |
|---|
| | 1113 | (when (and mark-active (not deactivate-mark)) |
|---|
| | 1114 | (let* ((ds (or (get this-command 'delete-selection) |
|---|
| | 1115 | (get this-command 'pending-delete))) |
|---|
| | 1116 | (nc (cond |
|---|
| | 1117 | ((not ds) nil) |
|---|
| | 1118 | ((eq ds 'yank) |
|---|
| | 1119 | 'cua-paste) |
|---|
| | 1120 | ((eq ds 'kill) |
|---|
| | 1121 | (if cua--rectangle |
|---|
| | 1122 | 'cua-copy-rectangle |
|---|
| | 1123 | 'cua-copy-region)) |
|---|
| | 1124 | ((eq ds 'supersede) |
|---|
| | 1125 | (if cua--rectangle |
|---|
| | 1126 | 'cua-delete-rectangle |
|---|
| | 1127 | 'cua-delete-region)) |
|---|
| | 1128 | (t |
|---|
| | 1129 | (if cua--rectangle |
|---|
| | 1130 | 'cua-delete-rectangle ;; replace? |
|---|
| | 1131 | 'cua-replace-region))))) |
|---|
| | 1132 | (if nc |
|---|
| | 1133 | (setq this-original-command this-command |
|---|
| | 1134 | this-command nc))))) |
|---|
| | 1135 | |
|---|
| | 1136 | ;; Handle shifted cursor keys and other movement commands. |
|---|
| | 1137 | ;; If region is not active, region is activated if key is shifted. |
|---|
| | 1138 | ;; If region is active, region is cancelled if key is unshifted (and region not started with C-SPC). |
|---|
| | 1139 | ;; If rectangle is active, expand rectangle in specified direction and ignore the movement. |
|---|
| | 1140 | ((if window-system |
|---|
| | 1141 | (memq 'shift (event-modifiers |
|---|
| | 1142 | (aref (this-single-command-raw-keys) 0))) |
|---|
| | 1143 | (or |
|---|
| | 1144 | (memq 'shift (event-modifiers |
|---|
| | 1145 | (aref (this-single-command-keys) 0))) |
|---|
| | 1146 | ;; See if raw escape sequence maps to a shifted event, e.g. S-up or C-S-home. |
|---|
| | 1147 | (and (boundp 'function-key-map) |
|---|
| | 1148 | function-key-map |
|---|
| | 1149 | (let ((ev (lookup-key function-key-map |
|---|
| | 1150 | (this-single-command-raw-keys)))) |
|---|
| | 1151 | (and (vector ev) |
|---|
| | 1152 | (symbolp (setq ev (aref ev 0))) |
|---|
| | 1153 | (string-match "S-" (symbol-name ev))))))) |
|---|
| | 1154 | (unless mark-active |
|---|
| | 1155 | (push-mark-command nil t)) |
|---|
| | 1156 | (setq cua--last-region-shifted t) |
|---|
| | 1157 | (setq cua--explicit-region-start nil)) |
|---|
| | 1158 | |
|---|
| | 1159 | ;; Set mark if user explicitly said to do so |
|---|
| | 1160 | ((or cua--explicit-region-start cua--rectangle) |
|---|
| | 1161 | (unless mark-active |
|---|
| | 1162 | (push-mark-command nil nil))) |
|---|
| | 1163 | |
|---|
| | 1164 | ;; Else clear mark after this command. |
|---|
| | 1165 | (t |
|---|
| | 1166 | ;; If we set mark-active to nil here, the region highlight will not be |
|---|
| | 1167 | ;; removed by the direct_output_ commands. |
|---|
| | 1168 | (setq deactivate-mark t))) |
|---|
| | 1169 | |
|---|
| | 1170 | ;; Detect extension of rectangles by mouse or other movement |
|---|
| | 1171 | (setq cua--buffer-and-point-before-command |
|---|
| | 1172 | (if cua--rectangle (cons (current-buffer) (point))))) |
|---|
