;; -*- mode: emacs-lisp; coding: hebrew-iso-8bit-unix; -*- ;; ekmarks.el --- EK marks (lines, chars, block) operation ;; Copyright (C) 1992-2003 Ehud karni ;; This file is NOT part of GNU Emacs, distribution conditions below. ;; ;; EHUD KARNI ינרק דוהא ;; Ben Gurion st' 14 ןוירוג ןב 'חר ;; Kfar - Sava 44 257 אבס - רפכ ;; =================================== ;; 972-(0)9-7659599 ;; =================================== ;; RCS: $Id: ekmarks.el,v 1.106 2000/03/05 11:22:43 ehud Exp ehud $ ;; ;; LOG: $Log: ekmarks.el,v $ ;; Revision 1.106 2000/03/05 11:22:43 ehud ;; Fixed bug in restored position, X selection, right2left local vars ;; when `mark-block-to-tmp'. Add capitalize-mark, winvert-encode-marked, ;; justify-left-marked, run-command-on-mark, himark-* functions. ;; ;; Revision 1.105 1998/11/11 11:43:53 ehud ;; Add metamail-marked, Really last revision for 19.34 ;; ;; Revision 1.104 1998/03/15 16:14:42 ehud ;; Last revision for 19.34 ;; ;; Revision 1.103 1996/02/19 10:43:05 ehud ;; Emacs 19.30 version ;; ;; Revision 1.102 1995/09/20 18:00:41 ehud ;; Options for X-terminal: visible mark ;; ;; Revision 1.101 1995/05/30 16:25:38 ehud ;; add winvert-marked (invert for PC Windows) ;; ;; Revision 1.100 1995/01/19 17:21:03 ehud ;; SW initial version control for all el's ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (defvar mark-1st nil "1st mark (ek) position, a cons cell: (marker column-number) for all marks, nil if not set") (defvar mark-2nd nil "2nd mark (ek) position, a cons cell: (marker column-number) for all marks, nil if not set") (defvar mark-2nd-marker (make-marker) "temp var for block mark - save lower right corner as a marker") (defvar both-marked t "Mark switch: nil-one mark set, t-none or both mark set") (defvar type-mark-set 1 "Mark switch 1: line mark, 2: character mark, 4: block mark") (defvar mark-ring-ek nil "Stack for pushed (ek) marks. used by push-mark-ek & pop-mark-ek") (defvar mark-move-off nil "*Mark move switch. t : mark operation does not move point, nil: move point by character or line according to mark type") (defvar mark-page-char "\n1" "*Top of Page (TOF) for page marking \\f : form feed (^L) look for real New Page character, \\n1 : a control character of 1 after new line (Fortran printer new page)") (defvar mark-sound nil "*Mark sound on marking switch t : mark operation sounds speaker with different notes on 1st & 2nd mark nil: do not sound speaker on marking (default)") (defvar mark-overlay-list nil "list of mark overlays (unmark deletes them).") "Define general functions for the Marked area" (defun visible-mark () "Make marked area visible" (if faces-on (mark-set-face 'mark))) (defun visible-unmark () "Make marked area normal" (if faces-on (while mark-overlay-list (delete-overlay (car mark-overlay-list)) (setq mark-overlay-list (cdr mark-overlay-list))))) (defun mark-set-face (FACE) "Set face of marked area to FACE (to mark only)" (if (mark-exist-chk) (save-window-excursion (visible-unmark) ;; clear overlay if exist (setq mark-overlay-list nil) ;; clear marks-overlay-list (let* ((buf (set-buffer (marker-buffer (car mark-1st)))) (pos (point-marker)) ;; current position in buf (m1 (marker-position (car mark-1st))) (m2 (marker-position (car mark-2nd)))) (if (/= type-mark-set 4) (if (= type-mark-set 1) (if (> m2 1) (mark-set-face-overlay m1 (1- m2) buf FACE)) (mark-set-face-overlay m1 m2 buf FACE)) (let ((c1 (cdr mark-1st)) (c2 (1+ (cdr mark-2nd)))) (goto-char m1) (setq m2 (min m2 (1- (point-max)))) (while (not (< m2 (point))) (setq m1 (+ (point) c1)) (end-of-line) (setq m1 (min m1 (point))) (goto-col c2 t) (mark-set-face-overlay m1 (point) buf FACE) (forward-line)))) (goto-char pos))))) ;; restore position (defun mark-set-face-overlay (BEG END BUF FACE) "make-overlay BEG END in BUF, set its `face' to FACE and its priority to 99. realy FACE is always `MARK'. Add to mark-overlay-list (for unmarking)." (let ((ov (make-overlay BEG END BUF nil t))) (overlay-put ov 'face FACE) (overlay-put ov 'priority 99) (setq mark-overlay-list (append (list ov) mark-overlay-list)))) (defun unmark (&optional nomsg) "Unmark: undo marking (even if no area marked)." (interactive) (visible-unmark) (setq both-marked t) (setq type-mark-set 1) (setq mark-1st nil) (setq mark-2nd nil) (if nomsg nil (message "Unmarked"))) (defun push-mark-ek () "Push current (ek) marks to stack and unmark." (interactive) (if (not mark-1st) (error "No marks to save (push)")) (setq mark-ring-ek (cons (list mark-1st mark-2nd both-marked type-mark-set) mark-ring-ek)) (unmark t) (message "mark(s) pushed")) (defun pop-mark-ek () "Pop pushed (ek) marks from stack (see push-ek-mark)." (interactive) (let ((tlst (car-safe mark-ring-ek))) (if (not tlst) (error "no saved (pushed) mark")) (visible-unmark) ; make current unvisible (setq mark-1st (nth 0 tlst)) (setq mark-2nd (nth 1 tlst)) (setq both-marked (nth 2 tlst)) (setq type-mark-set (nth 3 tlst)) (visible-mark) (setq mark-ring-ek (cdr mark-ring-ek)) (message "mark poped"))) ; (clear unmarked message) (defun pushed-mark-view () "Show all pushed (ek) marks, for each specify: buffer, type & value." (interactive) (let ((sv-buf (current-buffer)) (sv-pos (point)) (mrks mark-ring-ek) (cnt 0) buf m1 m2 typ) (if (null (car-safe mrks)) (message "No marks pushed to `mark-ring-ek'") (with-output-to-temp-buffer "*Help*" (while mrks (setq buf (car mrks)) (setq mrks (cdr mrks)) (setq cnt (1+ cnt)) (princ (format "Saved mark %d, " cnt)) (setq m1 (nth 0 buf)) (setq m2 (nth 1 buf)) (setq typ (nth 3 buf)) (setq buf (marker-buffer (car m1))) (if (null buf) (princ "***ITS BUFFER HAS BEEN DELETED***\n\n") (progn (set-buffer buf) (princ "buffer=") (prin1 (buffer-name buf)) (if (/= typ 4) (progn (if (= typ 1) (princ " lines") (princ " characters")) (copy-to-register 17 (marker-position (car m1)) (marker-position (car m2)))) (progn (princ " block") (goto-char (car m2)) (goto-col (cdr m2)) (if (or (eobp) (= (char-after (point)) ?\n)) (insert " ")) (copy-rectangle-to-register 17 (+ (marker-position (car m1)) (cdr m1)) (+ (marker-position (car m2)) (cdr m2))))) (princ ", Its value:\n") (setq buf (get-register 17)) (if (/= typ 4) (princ (format "\"%s\"" buf)) (while buf (prin1 (car buf)) (terpri) (setq buf (cdr buf)))) (terpri)))) (set-buffer sv-buf) (goto-char sv-pos))))) (defun mark-exist-chk (&optional arg) "check if mark set and marked area exist if optional MSG is given display standard msg, beep and return nil" (if (and mark-1st ;any marked area (marker-buffer (car mark-1st))) t ;return true (progn (setq both-marked t) ;signal unmarked (if arg (error "No marked area")) nil ))) (defun marks-check-swap () "Check (& swap) marks so 1st mark is < then 2nd" (let ((m1 mark-1st) (p1 (marker-position (car mark-1st))) (p2 (marker-position (car mark-2nd)))) (if (> p1 p2) (progn (setq mark-1st mark-2nd) (setq mark-2nd m1))))) (defun mark-2nd-same (arg) "Check if 2nd mark is same type as the 1st and in the same buffer" (interactive) (if (string-equal (buffer-name) (buffer-name (marker-buffer (car mark-1st)))) (if (/= arg type-mark-set) (progn (visible-mark) ; make mark visible (error "First mark is of other type, Unmark and re-Set"))) (error "First mark is not in this buffur"))) (defun mark-begin () "Go to the beginning of marked area (any type)" (interactive) (mark-goto-cons mark-1st t)) (defun mark-end () "Go to the end of marked area (any type)" (interactive) (mark-goto-cons mark-2nd t)) (defun mark-goto-cons (MARK-N &optional pop) "Go to the position (in buffer) of car of (MARKER column) Optional 2nd parameter POP non nil means pop to the marker buffer" (if (mark-exist-chk t) (let ((new-buf (marker-buffer (car MARK-N)))) (or (equal new-buf (current-buffer)) (set-buffer new-buf)) (goto-char (car MARK-N)) (if (= type-mark-set 4) (if (equal MARK-N mark-1st) (goto-col (1+ (cdr MARK-N))) (goto-col (cdr MARK-N)))) (if pop (pop-to-buffer new-buf))))) (defun marked-to-primary () "Copy current marked area (any type) to 'PRIMARY clipboard" (interactive) (mark-exist-chk t) (let (lines (x-select-enable-clipboard t) ;; save to clipboard too (strs "")) (if (/= type-mark-set 4) (save-excursion (set-buffer (marker-buffer (car mark-1st))) (copy-to-register 17 (marker-position (car mark-1st)) (marker-position (car mark-2nd))) (setq strs (get-register 17))) (save-excursion (mark-block-to-17 nil) (setq lines (get-register 17)) (while lines (setq strs (concat strs (car lines) "\n")) (setq lines (cdr lines))))) (setq strs (string-make-unibyte strs)) ;; (x-set-selection 'PRIMARY strs) ;; done by x-select-text (x-select-text strs t) (setq both-marked t))) "Define functions for the Mark-line" (defun mark-line () "Line mark set (1st or 2nd)" (interactive) (visible-unmark) (mark-exist-chk) (let ((sv-pos (point))) (if both-marked (progn (mark-line-set-1st) (message "First Line Mark Set")) (mark-line-set-2nd)) (goto-char sv-pos) (if (not mark-move-off) (forward-line))) (setq both-marked (not both-marked)) (visible-mark)) (defun mark-line-set-1st () "Line mark set - 1st only" (interactive) (beginning-of-line) (setq mark-1st (cons (point-marker) 0)) (setq type-mark-set 1) (mark-line-set-end)) (defun mark-line-set-end () "Line mark set, set ?L to eol" (interactive) (if (eobp) (newline 1) (forward-line)) (setq mark-2nd (cons (point-marker) 0))) (defun mark-line-set-2nd () "Line mark set - 2nd only" (interactive) (if (not (mark-2nd-same 1)) (progn (beginning-of-line) (setq mark-2nd (cons (point-marker) 0)) (marks-check-swap) (mark-goto-cons mark-2nd) (mark-line-set-end) (message "Second Line Mark Set")))) "Mark character operations" (defun mark-char () "Character mark set (1st or 2nd)" (interactive) (visible-unmark) (mark-exist-chk) (let ((sv-pos (point)) (col (column-no))) (if both-marked (mark-char-set-1st col) (mark-char-set-2nd col)) (goto-char sv-pos) (if (not mark-move-off) (forward-char 1))) (setq both-marked (not both-marked)) (visible-mark)) (defun mark-char-set-1st (col) "Character mark set - 1st only" (interactive) (setq mark-1st (cons (point-marker) col)) (setq type-mark-set 2) (forward-char) (setq mark-2nd (cons (point-marker) col)) (message "First Character Mark Set")) (defun mark-char-set-2nd (col) "Character mark set - 2nd only" (interactive) (if (not (mark-2nd-same 2)) (progn (setq mark-2nd (cons (point-marker) col)) (marks-check-swap) (mark-goto-cons mark-2nd) (setq col (column-no)) (forward-char) (setq mark-2nd (cons (point-marker) col)) (message "Second Character Mark Set")))) "Mark block operations" (defun mark-block () "Block mark set (1st or 2nd)" (interactive) (visible-unmark) (mark-exist-chk) (let ((col (1- (column-no)))) (if both-marked (mark-block-set-1st col) (mark-block-set-2nd col))) (setq both-marked (not both-marked)) (visible-mark)) (defun mark-block-set-1st (col) "Block mark set - 1st only" (setq mark-1st (cons (save-excursion (beginning-of-line) (point-marker)) col)) (setq type-mark-set 4) (setq mark-2nd mark-1st) (mark-block-set-end) (message "First Block Mark Set")) (defun mark-block-set-2nd (col) "Block mark set - 2nd only" (if (not (mark-2nd-same 4)) (progn (setq mark-2nd (cons (save-excursion (beginning-of-line) (point-marker)) col)) (mark-block-check-swap) (mark-block-set-end) (message "Second Block Mark Set")))) (defun mark-block-set-end () "Block mark set, inc mark-2nd column by 1" (setq mark-2nd (cons (car mark-2nd) (1+ (cdr mark-2nd))))) (defun mark-block-check-swap () "Block mark check (& swap) so mark-1st is set to upper left corner, mark-2nd to right bottom corner." (let ((tmp 0) (p1 (car mark-1st)) (p2 (car mark-2nd)) (c1 (cdr mark-1st)) (c2 (cdr mark-2nd))) (if (> (marker-position p1) (marker-position p2)) (progn (setq tmp p1) (setq p1 p2) (setq p2 tmp))) (if (> c1 c2) (progn (setq tmp c1) (setq c1 c2) (setq c2 tmp))) (setq mark-1st (cons p1 c1)) (setq mark-2nd (cons p2 c2)))) (defun mark-block-to-17 (del-flg) "Copy marked block area to register 17 (^Q), non nil DELETE-FLAG means delete marked area." (mark-goto-cons mark-2nd) (if (or (eobp) (= (char-after (point)) ?\n)) (insert " ")) (copy-rectangle-to-register 17 ;^Q (+ (marker-position (car mark-1st)) (cdr mark-1st)) (+ (marker-position (car mark-2nd)) (cdr mark-2nd)) del-flg)) (defun mark-block-to-tmp (&optional LOCAL) "Copy marked block area to temp buffer ` *Block-tmp*' If optional flag LOCAL is non nil, copy local vars to temp buffer." (visible-unmark) (setq both-marked t) ;;marks used ! (set-marker mark-2nd-marker (+ (marker-position (car mark-2nd)) (cdr mark-2nd) 1) (marker-buffer (car mark-2nd))) (mark-block-to-17 nil) (let ((nbf (get-buffer-create " *Block-tmp*"))) (if LOCAL (copy-local-vars nbf) (set-buffer nbf))) (delete-region (point-min) (point-max)) (let ((lines (get-register 17))) (while lines (insert (car lines) "\n") (setq lines (cdr lines)))) (delete-char -1) (goto-char 1)) (defun copy-local-vars (NEW-BUF) "Copy all current buffer local vars to NEW-BUF killing all its previuos local vars (if any). Use `get-buffer-create' to ensure its existence." (interactive) (let ((blv (buffer-local-variables)) (lmp (current-local-map)) v-nm v-va) ;var name, var-value (set-buffer NEW-BUF) (kill-all-local-variables) (use-local-map lmp) (while blv (setq v-va (car blv)) (setq v-nm (car v-va)) (setq v-va (cdr-safe v-va)) (or (member v-nm '(buffer-read-only buffer-file-name buffer-auto-save-file-name)) (condition-case () (set (make-local-variable v-nm) v-va) (error nil))) (setq blv (cdr blv))))) (defun mark-block-restore () "Restore marked block area from temporary buffer \" *Block-tmp*\" and kill it" (let ((svb '(nil)) (ix 0) (luc (+ (marker-position (car mark-1st)) (cdr mark-1st))) (rdc (+ (marker-position (car mark-2nd)) (cdr mark-2nd)))) (goto-char (point-max)) (insert " ") (goto-char (point-min)) (while (not (eobp)) (setq svb (cons (buffer-substring (point) (progn (forward-line 1) (1- (point)))) svb)) (setq ix (1+ ix))) (set-buffer-modified-p nil) (set-buffer (marker-buffer (car mark-1st))) (delete-rectangle luc rdc) (goto-char luc) (setq luc (1+ (cdr mark-1st))) (while (> ix 0) (setq ix (1- ix)) (insert (nth ix svb)) (forward-line 1) (goto-col luc)) (setq rdc (- (marker-position mark-2nd-marker) (marker-position (car mark-2nd)) 1)) (setcdr mark-2nd rdc) (kill-buffer " *Block-tmp*")) (visible-mark)) (defun overlay-marked () "Overlay marked block on this point (upper left corner)" (interactive) (if (/= type-mark-set 4) (error "Block mark requierd for overlay") (let ((col (column-no)) (lns 0) (luc (+ (marker-position (car mark-1st)) (cdr mark-1st))) (rdc (+ (marker-position (car mark-2nd)) (cdr mark-2nd)))) (visible-unmark) (setq both-marked t) ;;marks used ! (save-excursion (mark-block-to-17 nil) (setq lns (count-lines luc rdc))) (setq luc (point)) (if (> lns 0) (forward-line (1- lns))) (goto-col (+ col (cdr mark-2nd) (- (cdr mark-1st)))) (setq rdc (point)) (goto-char luc) (delete-rectangle luc rdc) (insert-register 17) (visible-mark)))) (defun mark-page-ek (&optional arg) "Mark a whole page by characters (including the ^L/1 at the begining) A numeric arg specifies to move forward or backward by that many pages, thus marking a page other than the one point was originally in. Uses the variable `mark-page-char' which is the top-of-page string - ^L (\\f) - real new page character for Ascii printer files \\n1 - control character = 1 for Fortran printer files." (interactive "P") (let (beg end (ffl (1- (length mark-page-char))) (pos (point))) (or arg (setq arg 0)) (if (search-backward mark-page-char (point-min) t) (forward-char ffl) (goto-char (point-min))) (and (= arg 0) (setq beg (point))) (and (> arg 0) (not (forward-char 1)) (search-forward mark-page-char (point-max) t arg) (setq beg (1- (point)))) (and (< arg 0) (search-backward mark-page-char (point-min) t (- arg)) (not (forward-char ffl)) (setq beg (point))) (if beg (progn (unmark t) (goto-char beg) (mark-char) (if (search-forward mark-page-char (point-max) t) (backward-char (+ 2 ffl)) (goto-char (1- (point-max)))) (setq end (1+ (point))) (mark-char) (message "marked page: characters %d-%d" beg end))) (goto-char pos))) (defun mark-defun-ek (&optional arg) "Mark the defun (by characters mark) +/- arg away from point." (interactive "p") (let (beg end eodf (pos (point))) (end-of-defun arg) (setq eodf (1- (point))) (and (not (eobp)) (beginning-of-defun) (progn (unmark t) (mark-char) (re-search-forward "[ \t\n][^ \t\n]" (point-max) t) ; defun name (setq beg (1- (point))) ; 1st cahr (re-search-forward "[^ \t\n][ \t\n]" (point-max) t) (setq end (1- (point))) ; last cahr (goto-char eodf) (mark-char) (message "marked defun: \"%s\"" (buffer-substring beg end)))) (goto-char pos))) (defun mark-word-ek (&optional arg) "Mark the word (string of any non white spaces, by characters mark) arg (+ or -) strings away from point." (interactive "P") (let (beg end (pos (point))) (or arg (setq arg 0)) (if (looking-at "[ \n\t]") (progn (forward-to-non-blank) (and (> arg 0) (setq arg (1- arg)))) (progn (forward-char 1) (backward-to-non-blank))) (and (= arg 0) (looking-at "[^ \n\t]") (setq beg (point))) (and (> arg 0) (re-search-forward "[ \t\n][^ \t\n]" (point-max) t arg) (setq beg (1- (point)))) (and (< arg 0) (re-search-backward "[ \t\n][^ \t\n]" (point-min) t (- arg)) (setq beg (1+ (point)))) (if beg (progn (unmark t) (goto-char beg) (mark-char) (goto-char beg) (if (re-search-forward "[^ \t\n][ \t\n]" (point-max) t) (backward-char 2) (goto-char (1- (point-max)))) (setq end (1+ (point))) (mark-char) (message "marked word: \"%s\"" (buffer-substring beg end)))) (goto-char pos))) (defun mark-word-only-ek (&optional arg) "Mark the `word' only (string of alpha & digits only, by characters mark) arg (+ or -) `words' away from point." (interactive "P") (let (beg end (pos (point))) (or arg (setq arg 0)) (if (looking-at "\\W") (progn (forward-word 1) (forward-word -1) (and (> arg 0) (setq arg (1- arg)))) (progn (forward-word 1) (forward-word -1))) (and (= arg 0) (looking-at "\\w") (setq beg (point))) (and (> arg 0) (forward-word arg) (setq beg (1- (point)))) (and (< arg 0) (forward-word (- arg)) (setq beg (point))) (if beg (progn (unmark t) (goto-char beg) (mark-char) (goto-char beg) (if (forward-word 1) (backward-char 1)) (setq end (point)) (mark-char) (message "marked `word': \"%s\"" (buffer-substring beg end)))) (goto-char pos))) (defun mark-whole-buffer-ek () "Mark the whole buffer in character marks" (interactive) (let ((pos (point))) (goto-char (point-min)) (if (eobp) nil ;do not do to empty buffer (unmark t) (mark-char) (goto-char (1- (point-max))) (mark-char) (goto-char pos)))) "Copy & Move marked area" (defun copy-marked () "Copy marked area (any mark) to this point/line. If nothing is marked, copy doubles this line." (interactive) (if (not (mark-exist-chk)) (progn (mark-line-set-1st) (copy-move-marked-line nil) (unmark)) (progn (visible-unmark) (cond ((= type-mark-set 1) (copy-move-marked-line nil)) ((= type-mark-set 2) (copy-move-marked-char nil)) ((= type-mark-set 4) (copy-move-marked-block nil))) (visible-mark))) (setq both-marked t)) (defun move-marked () "Move marked area (any type) to this point/line." (interactive) (if (mark-exist-chk t) (progn (visible-unmark) (cond ((= type-mark-set 1) (copy-move-marked-line t)) ((= type-mark-set 2) (copy-move-marked-char t)) ((= type-mark-set 4) (copy-move-marked-block t))) (unmark t)))) (defun copy-move-marked-line (del-flg) "Copy marked line to beginning of this line" ;; (current-column) ;; fix for bug in emacs 21 minibuffer (beginning-of-line) (copy-move-marked-char del-flg)) (defun copy-move-marked-char (del-flg) "Copy marked area to this point" (save-excursion (set-buffer (marker-buffer (car mark-1st))) (copy-to-register 17 (marker-position (car mark-1st)) (marker-position (car mark-2nd)) del-flg)) (insert-register 17)) (defun copy-move-marked-block (del-flg) "Copy marked block to this point" (save-excursion (mark-block-to-17 del-flg)) (insert-register 17)) ;; master functions for all marked area operations (defun call-func-on-marked (types err-msg pop-blk range restore func &rest args) "Runs lisp function on marked area. Argument are: TYPES - marks type allowed add all allowed (1-lines, 2-char, 4-block) ERR-MSG - string to display by error if type mis-match. POP-BLK - if non nil, pop to temp block buffer or mark buffer before calling Also - do NOT narrow to marked region. RANGE - if non nil, add 2 arguments to the funcall before ARGS - start end. RESTORE - if non nil, restore blocked area and reset marks. FUNC - lisp function name to call. ARGS - more arguments to pass to the called func." (mark-exist-chk t) ;; check for marked area (if (zerop (logand type-mark-set types)) ;; check for correct type (error err-msg)) (visible-unmark) (save-window-excursion (if (/= type-mark-set 4) (save-excursion (set-buffer (marker-buffer (car mark-1st))) (save-restriction (and pop-blk (pop-to-buffer (current-buffer)) (if range (setq args (append (list (marker-position (car mark-1st)) (marker-position (car mark-2nd))) args) range nil) (setq pop-blk nil))) (or pop-blk (narrow-to-region (marker-position (car mark-1st)) (marker-position (car mark-2nd)))) (if range (setq args (append (list (point-min) (point-max)) args))) (goto-char (point-min)) (condition-case () (apply func args) (error nil)))) (save-excursion (mark-block-to-tmp 'local) (if pop-blk (pop-to-buffer (current-buffer))) (if range (setq args (append (list (point-min) (point-max)) args))) (condition-case () (apply func args) (error nil)) (if restore (mark-block-restore) (set-marker mark-2nd-marker nil))))) (setq both-marked t) (visible-mark)) ;; "Fill marked area" (defun fill-marked (char) "Fill marked area (of any type)" (interactive "*cType char to fill marked area - ") (mark-exist-chk t) (call-func-on-marked 7 "error" nil 'range 'rstr 'fill-marked-sub char)) (defun fill-marked-sub (pnt-min pnt-max filc) "Fill a continues region from PNT-MIN to PNT-MAX with FILL character" (interactive) (save-excursion (goto-char (min pnt-min pnt-max)) (while (< (point) (max pnt-min pnt-max)) (if (/= ?\n (char-after (point))) (put-char-replace filc) (forward-char))))) ;;"Delete marked area" (defun delete-marked () "Delete marked area (any type)." (interactive) (call-func-on-marked 7 "error" nil 'range 'restore 'kill-region) (unmark t)) (defun change-marked (translate) "Change marked area according to TRANSLATE: 1=English to lower case, 2=English to upper case, 3=English Lower case to Hebrew, UNIX (E0h-FBh) or DOS (80h-9Bh) 4=Hebrew, UNIX (E0h-FBh) or DOS (80h-9Bh) to English Lower case (40h-5Bh) 5=PC-DOS Hebrew (80H-9Bh) to UNIX/WINDOW Hebrew (E0h-FBh) 6=UNIX/WINDOW Hebrew (E0h-FBh) to PC-DOS Hebrew (80H-9Bh) 7=English lower case & special chars to Hebrew (according to pc Keyboard) 8=Hebrew & special chars to English lower case (according to pc Keyboard) 9=NOS 6/12 to English upper & lower case (^x & @x) 10=NOS 6/12 to English upper case & Hebrew (^x & @x)" (interactive "NConvert (0-help/1->l/2->U/3-LH/4-HL/5-HPU/6-HUP/7-KEH/8-KHE/9-NOSE/10-NOSH): ") (if (= translate 0) (progn (describe-function 'change-marked) (call-interactively 'change-marked)) (call-func-on-marked 7 "error" nil 'range 'restore 'change-marked-sub translate))) (defun change-marked-sub (p_1 p_2 translate) "change area from p_1 to p_2 according to TRANSLATE see documentation of change-marked." (cond ((= translate 1) (trns-region-range p_1 p_2 65 90 32)) ;English to lower ((= translate 2) (trns-region-range p_1 p_2 97 122 -32)) ;English to upper ((= translate 3) (trns-region-range p_1 p_2 ?` ?z (- Alef-is ?`))) ;English lower to Hebrew ((= translate 4) (trns-region-range p_1 p_2 Alef-is Tav-is (- ?` Alef-is))) ;Hebrew to English lower case ((= translate 5) (trns-region-range p_1 p_2 128 154 96)) ;Hebrew PC-DOS to UNIX/WINDOW €-->א ((= translate 6) (trns-region-range p_1 p_2 224 250 -96)) ;Hebrew UNIX/WINDOW to PC-DOS א-->€ ((= translate 7) (translate-region p_1 p_2 hebrew-keyboard-chars)) ;Keyboard Hebrew to English ((= translate 8) (translate-region p_1 p_2 english-keyboard-chars)) ;Keyboard English to Hebrew ((= translate 9) (trns-region-nos2ux p_1 p_2 32 "@^?:??`")) ;NOS2UX English ((= translate 10) (trns-region-nos2ux p_1 p_2 160 (concat "@^?:??" (vector Alef-is)))) ;NOS2UX Hebrew (t (error "translation requested is %d, shuld be 1-10" translate)))) (defun lower-marked () "Change marked area to lower case" (interactive) (change-marked 1)) (defun upper-marked () "Change marked area to upper case" (interactive) (change-marked 2)) (defun hebrew-marked () "Change marked area upper case to Hebrew" (interactive) (change-marked 3)) (defun english-marked () "Change marked area Hebrew to upper case" (interactive) (change-marked 4)) (defun pc2unix-marked () "Change marked area PC Hebrew to UNIX Hebrew" (interactive) (change-marked 5)) (defun unix2pc-marked () "Change marked area UNIX Hebrew to PC Hebrew" (interactive) (change-marked 6)) (defun kbd-e2h-marked () "Change marked area lower case to Hebrew according to PC keyboard" (interactive) (change-marked 7)) (defun kbd-h2e-marked () "Change marked area Hebrew to lower case according to PC keyboard" (interactive) (change-marked 8)) (defun nos2eng-marked () "Change marked area NOS 6/12 to U/L English" (interactive) (change-marked 9)) (defun nos2heb-marked () "Change marked area NOS 6/12 to English/Hebrew" (interactive) (change-marked 10)) (defun capitalize-mark () "convert the marked-area to capitalized form." (interactive) (call-func-on-marked 7 "error" nil 'range 'restore 'capitalize-region)) ;; Replace in marked area only (defun replace-in-marked (arg) "Replace (string/word/reg-exp) in marked area only" (interactive "P") (call-func-on-marked 7 "error" 'pop nil 'restore 'replace-txt arg)) ;; External operation on marked area ;; compute, sum, invert, winvert, justify-right, highlight, shift, sort, tprint, eval (defun compute-marked (&optional NOMSG) "Compute the marked area as an arithemtic expression See help for the `compute' function." (interactive) (call-func-on-marked 7 "error" nil 'range nil 'compute-region NOMSG)) (defun compute-marked-rep () "Replace the marked area with its `Compute'd value as an arithemtic expression See help for the `compute' function." (interactive) (compute-marked 'REP)) (defun sum-marked (&optional NOMSG) "Sum all the numbers in the marked area" (interactive) (call-func-on-marked 7 "error" nil 'range nil 'sum-numbers-region NOMSG)) (defun invert-marked () "Invert all lines in marked area only" (interactive) (call-func-on-marked 7 "error" nil nil 'restore 'invert-all-lines)) (defun utf8-2-iso-hebrew-marked () "Convert Hebrew UTF-8 to ISO-8859-8 and then run winvert (Win invert - invert Hebrew for PC Windows) on all lines in marked area ONLY" (interactive) (call-func-on-marked 7 "error" nil nil 'restore 'utf8-2-iso-hebrew)) (defun utf8-2-iso+winvert-marked () "Convert Hebrew UTF-8 to ISO-8859-8 and then run winvert (Win invert - invert Hebrew for PC Windows) on all lines in marked area ONLY" (interactive) (call-func-on-marked 7 "error" nil nil 'restore 'utf8-2-iso+winvert)) (defun winvert-marked () "Win invert (for PC Windows) all lines in marked area only" (interactive) (call-func-on-marked 7 "error" nil nil 'restore 'winvert-all-lines)) (defun winvert-encode-marked () "Win invert (for PC Windows) all lines in marked area only" (interactive) (call-func-on-marked 7 "error" nil nil 'restore 'winvert-encode-all-lines)) (defun justify-right-marked (&optional LEFT) "Justify right the text in block marked area Optional LEFT prefix arg non nil means justify left." (interactive "P") (call-func-on-marked 4 "Only block marked can be justified" nil nil 'restore 'justify-right-marked-internal LEFT)) (defun justify-right-marked-internal (LEFT) "Internal function for `justify-right-marked'" (goto-char (point-min)) (end-of-line) (justify-all-lines 1 (1- (point)) LEFT)) (defun justify-left-marked () "Justify left the text in block marked area." (interactive) (justify-right-marked 'LEFT)) (defun highlight-marked () "Highlight the text (using hilit19) in the marked area" (interactive) (call-func-on-marked 3 "Block marked can not be highlighted" nil 'range 'restore 'hilit-highlight-region)) (defun shift-marked (&optional arg) "Shift right marked area (lines or block) by prefixed ARG (default=1) columns negative ARG value means shift left.\n Shifts right by inserting space at the left edge. Shifts left by deleting the left column. The right edge moves (nothing is inserted or deleted).\n" (interactive "pShift right (- shift left) by: ") (if arg t (setq arg 1)) (call-func-on-marked 5 "shift of marked are can be done with only with line or block marks" nil nil 'restore 'shift-all-lines arg)) (defun shift-marked-left (&optional arg) "Shift left marked area (lines or block) by prefixed ARG (default=1) columns negative ARG value means shift right.\n Shifts left by deleting the left column. Shifts right by inserting space at the left edge. The right edge moves (nothing is inserted or deleted).\n" (interactive "pShift left (- shift right) by: ") (if arg t (setq arg 1)) (setq arg (- arg)) (shift-marked arg)) ;; "Sort marked area only (full lines & by columns)" (defun sort-marked (&optional arg) "Sort marked area only, no key - use the whole line, block - sort block only If prefixed ARG is given - sort in reverse order" (interactive "P") (if arg (setq arg 'REVERSED) (setq arg nil)) (call-func-on-marked 7 "error" nil 'range 'restore 'right2left-sort-lines arg)) (defun sort-by-columns-marked (&optional arg) "Sort marked area by columns, sort all the lines marked (even partialy) can be done if mark is block or character only If prefixed ARG is given - sort in reverse order" (interactive "P") (if arg (setq arg 'REVERSED) (setq arg nil)) (if (mark-exist-chk t) (if (= type-mark-set 1) (error "sort by columns can not be done with line marks") (let ((m1 (marker-position (car mark-1st))) (c1 (cdr mark-1st)) (m2 (marker-position (car mark-2nd))) (c2 (cdr mark-2nd)) (ep)) (visible-unmark) (save-excursion (set-buffer (marker-buffer (car mark-1st))) (goto-char m2) (end-of-line) (setq ep (point)) (if (= type-mark-set 2) (progn (sort-columns arg m1 m2) (goto-char (1+ (- m1 c1))) (goto-col c1) (setq mark-1st (cons (point-marker) c1)) (goto-char ep) (goto-col c2) (setq mark-2nd (cons (point-marker) c2))) (progn (sort-columns arg (+ m1 c1) (+ m2 c2)) (goto-char m1) (setq mark-1st (cons (point-marker) c1)) (goto-char ep) (beginning-of-line) (setq mark-2nd (cons (point-marker) c2))))) (visible-mark) (setq both-marked t))))) (defun tprint-marked () "Print marked area on slave printer (using tprint)" (interactive) (mark-exist-chk t) (if (y-or-n-p "Are you sure you want to tprint marked area ? ") (progn (message "printing marked area ..." ) ; clear question (call-func-on-marked 7 "error" nil 'range nil 'tprint)))) (defun eval-marked () "eval marked area (chars or lines only)" (interactive) (call-func-on-marked 7 "error" nil 'range nil 'eval-marked-internal)) (defun eval-marked-internal (beg end) "eval marked area - internal function" (let ((standard-output (get-buffer-create "*evaled-buf*")) (saved-buf (buffer-name))) (pop-to-buffer standard-output) (goto-char (point-max)) (princ "\nEval result: ") (set-buffer saved-buf) (eval-region beg end standard-output))) ;; ispell-marked area (by use of ispell-region) (defun ispell-marked () "Spell check (using ispell) in marked area only" (interactive) (require 'ispell) (call-func-on-marked 7 "error" 'pop 'range 'restore 'ispell-region)) (defun flyspell-marked () "Spell check (using flyspell) in marked area only" (interactive) (require 'flyspell) (call-func-on-marked 3 "You can not `flyspell' blocked mark" 'nil 'range 'restore 'flyspell-region)) ;; metamail marked area (by use of metamail-region) (defun metamail-marked () "Process marked area through `metamail'. Marked area is replaced by the output of `metamail' and re-marked. Can be done to characters or lines marked area only." (interactive) (call-func-on-marked 3 "You can not `metamail' blocked mark" nil 'range 'restore 'metamail-region)) (defun base64-decode-marked () "Marked area is replaced by the output of `base64-decode-region' and re-marked. Can be done to characters or lines marked area only." (interactive) (call-func-on-marked 3 "You can not `base64-decode' blocked mark" nil 'range 'restore 'base64-decode-region)) (defun quoted-decode-marked () "Marked area is replaced by the output of `rmail-decode-quoted-printable' and re-marked. Can be done to characters or lines marked area only." (interactive) (call-func-on-marked 3 "You can not `decode-quoted-printable' blocked mark" nil 'range 'restore 'rmail-decode-quoted-printable)) (defun decode-coding-marked (coding-system) "Marked area is replaced by the output of `decode-coding-region' and re-marked. Can be done on characters or lines marked area only." (interactive "ZCoding system for decoding: ") (or coding-system (setq coding-system 'latin-1-unix)) (call-func-on-marked 3 "You can not `decode-coding-region' blocked mark" nil 'range 'restore 'decode-coding-region coding-system)) (defun encode-coding-marked (coding-system) "Marked area is replaced by the output of `encode-coding-region' and re-marked. Can be done on characters or lines marked area only." (interactive "ZCoding system for encoding: ") (or coding-system (setq coding-system 'latin-1-unix)) (call-func-on-marked 3 "You can not `encode-coding-region' blocked mark" nil 'range 'restore 'encode-coding-region)) (defun run-command-on-marked (command) "Runs `shell-command-on-region' on the current marked area." (interactive (let ((string (read-from-minibuffer "Shell command on marked area: " nil nil nil 'shell-command-history))) (list string))) (call-func-on-marked 7 "error" nil 'range nil 'shell-command-on-region command)) (defun count-word-marked () "count words (text between white spaces) in marked area (any type)." (interactive) (call-func-on-marked 7 "error" nil nil 'restore 'count-matches "[^ \n\t]+") (unmark t)) (defun reflow-marked (JUSTIFY) "Reflow the marked area by use of `fill-region-as-paragraph' Can be done on all kinds of mark but it behave differently: line marked are the normal fill-region (in R2L mode use the right2left-1st-col as the fill column. character marked - the fill column is set to the 2nd mark, In R2L fill column is: right2left-1st-col + 1 - 2nd mark column. block mark - reflow the BLOCK only with columns set to block width. Optional prefix JUSTIFY means add extra spaces to justify on both sides." (interactive "P") (let ((f-c fill-column) (r2l-fc right2left-1st-col)) (cond ((= type-mark-set 2) ;; character (setq f-c (cdr mark-2nd)) (setq r2l-fc (- r2l-fc f-c -1))) ((= type-mark-set 4) ;; block marked (setq f-c (setq r2l-fc (- (cdr mark-2nd) (cdr mark-1st)))))) (if right2left-on (setq f-c r2l-fc)) (call-func-on-marked 7 "error" 'pop nil 'restore 'reflow-marked-r2l-internal JUSTIFY f-c right2left-on))) (defun reflow-marked-r2l-internal (JUSTIFY f-col r2l) "Internal function for `reflow-marked'" (let ((fill-column f-col) (mlns (count-lines (point-min) (point-max)))) (if r2l (invert-all-lines)) (fill-region-as-paragraph (point-min) (point-max) JUSTIFY) (if (/= type-mark-set 4) ;; block marked (if r2l (invert-all-lines right2left-1st-col)) (goto-char (point-max)) (while (> mlns (count-lines (point-min) (point-max))) (insert "\n") (goto-col f-col)) (invert-all-lines f-col) (if (not r2l) (invert-all-lines f-col))))) (defun clear-properties-marked () "Clear all text properties from the marked area (any type)." (interactive) (let ((inhibit-read-only t)) ;; (call-func-on-marked 7 "error" nil 'range 'restore 'remove-text-properties ;; '(read-only nil field nil invisible nil intangible nil)) (call-func-on-marked 7 "error" nil 'range 'restore 'set-text-properties nil))) ;; ================ Hi(ghlight)-mark ====================================================== (defvar himark-overlay-list nil "list of high-mark overlays (himark-unset deletes them).") (make-variable-buffer-local 'himark-overlay-list) (defvar himark-overlay-face 'highlight "Name of face (quoted symbol) to use for himark. e.g. (setq himark-overlay-face 'modeline) Use list-faces-display to see all available faces") (defun himark-unset () "Remove himark overlay" (interactive) (if faces-on (while himark-overlay-list (delete-overlay (car himark-overlay-list)) (setq himark-overlay-list (cdr himark-overlay-list))))) (defun himark-set (arg) "Highlight all occurrence of string in this buffer)" (interactive "P") (let ((wrdd (concat "[^0-9A-Za-z" (vector Alef-is ?- Tav-is) "\-]")) (src-i 9) oc-src ov (pos (point))) (get-search-string arg) (if search-indicator (setq src-i search-indicator)) (if (= src-i 1) ;; 1=reg_exp, leave as is (setq oc-src search-string) (and (setq oc-src (regexp-quote search-string)) ;;0,other-quote regexp (= src-i 0) ;; word: add delimitors (setq oc-src (concat wrdd oc-src wrdd)))) (goto-char (point-min)) (while (re-search-forward oc-src nil t) (setq ov (make-overlay (match-beginning 0) (match-end 0))) (overlay-put ov 'face himark-overlay-face) (overlay-put ov 'priority 98) (setq himark-overlay-list (append (list ov) himark-overlay-list))) (goto-char pos))) ;;============================ end of ekmarks.el ==============================