;;; ---------------------------------------------------------------------------
;;; BlockRename.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; RENAME BLOCKS IN BULK FROM A LIST
;;;
;;; PURPOSE
;;;   Renames many blocks in one go, from a two-column file of old and new
;;;   names. For bringing a drawing onto the office standard, or for tidying up
;;;   after a consultant whose block names mean nothing to anyone else.
;;;
;;;   The file is plain text, one pair per line, comma separated:
;;;
;;;       DOOR1,D-SGL-900
;;;       DOOR2,D-SGL-1000
;;;       WIN-A,W-CSMT-600
;;;
;;;   Lines starting with a semicolon or a hash are ignored, so the file can
;;;   carry notes.
;;;
;;;   Names can also be typed in a pair at a time, which suits a handful.
;;;
;;; WHAT IT CHECKS BEFORE CHANGING ANYTHING
;;;   Every rename is tested first and the whole list reported, because a
;;;   half-applied rename is worse than none:
;;;
;;;     - the old name must exist
;;;     - the new name must not already be taken by a different block
;;;     - a name cannot appear as both an old and a new name in the same list,
;;;       which would make the result depend on the order things happened in
;;;     - anonymous blocks, which begin with a star, are left alone
;;;
;;; WHAT WAS FIXED
;;;   The routine this replaces could not run at all. It called a function named
;;;   LOOKUP_BLOCK to get each new name and a command named C:L to load that
;;;   function - and neither is in the file, nor anywhere in the collection. Its
;;;   own comment said C:L was "my function for loading lisp routines".
;;;
;;;   It then sat in a loop waiting for LOOKUP_BLOCK to appear:
;;;
;;;       (while (null lookup_block) (princ "\Load lookup function...") (C:L))
;;;
;;;   which on any machine but the author's is an endless loop calling an
;;;   undefined command. It also ran (C:ARENAME) at the end of the file, so
;;;   merely loading it started all this.
;;;
;;;   The concept was sound and is what is built here.
;;;
;;;   BLOCKRENAME  - rename blocks in bulk
;;; ---------------------------------------------------------------------------

(defun BRen:Split ( s sep / i ch cur out )
    (setq i 0 cur "" out nil)
    (while (< i (strlen s))
        (setq i (1+ i) ch (substr s i 1))
        (if (= ch sep)
            (setq out (cons cur out) cur "")
            (setq cur (strcat cur ch))))
    (reverse (cons cur out))
)

(defun BRen:Trim ( s )
    (while (and (> (strlen s) 0) (member (substr s 1 1) '(" " "\t" "\r")))
        (setq s (substr s 2)))
    (while (and (> (strlen s) 0) (member (substr s (strlen s) 1) '(" " "\t" "\r")))
        (setq s (substr s 1 (1- (strlen s)))))
    s
)

(defun BRen:Pad ( s w )
    (setq s (substr s 1 w))
    (while (< (strlen s) w) (setq s (strcat s " ")))
    s
)

(defun c:BLOCKRENAME ( / *error* vars vals how path fh line parts pairs
                         old new olds news problems ok n v done )

    (setq vars '("CMDECHO") vals (mapcar 'getvar vars))

    (defun BRen:Restore ( )
        (if fh (vl-catch-all-apply 'close (list fh)))
        (setq fh nil)
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End"))
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        (princ)
    )

    (defun *error* ( msg )
        (BRen:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BLOCKRENAME error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (initget "File Type")
    (setq how (getkword "\nNames from [File/Type] <File>: "))
    (if (null how) (setq how "File"))

    ;; --- gather the pairs ---------------------------------------------------
    (setq pairs nil)

    (if (= how "File")
        (progn
            (setq path (getfiled "List of old,new block names" "" "csv;txt" 4))
            (if path
                (progn
                    (setq fh (open path "r"))
                    (if (null fh)
                        (princ (strcat "\n** Cannot read " path " **"))
                        (progn
                            (while (setq line (read-line fh))
                                (setq line (BRen:Trim line))
                                (if (and (/= "" line)
                                         (not (member (substr line 1 1) '(";" "#"))))
                                    (progn
                                        (setq parts (BRen:Split line ","))
                                        (if (> (length parts) 1)
                                            (setq pairs (cons
                                                (cons (BRen:Trim (car parts))
                                                      (BRen:Trim (cadr parts)))
                                                pairs))))))
                            (close fh)
                            (setq fh nil pairs (reverse pairs)))))))

        (progn
            (setq done nil)
            (while (not done)
                (setq old (BRen:Trim (getstring t "\n  Old name <Enter to finish>: ")))
                (if (= "" old)
                    (setq done t)
                    (progn
                        (setq new (BRen:Trim (getstring t "  New name: ")))
                        (if (/= "" new)
                            (setq pairs (cons (cons old new) pairs))))))
            (setq pairs (reverse pairs))))

    (if (null pairs)
        (princ "\nNothing to rename.")
        (progn
            ;; --- check every one before touching anything -------------------
            (setq olds (mapcar 'car pairs)
                  news (mapcar 'cdr pairs)
                  problems nil ok nil)

            (foreach pr pairs
                (setq old (car pr) new (cdr pr))
                (cond
                    ((wcmatch old "`**")
                     (setq problems (cons (strcat old " - anonymous, left alone") problems)))
                    ((not (tblsearch "BLOCK" old))
                     (setq problems (cons (strcat old " - no such block") problems)))
                    ((= (strcase old) (strcase new))
                     (setq problems (cons (strcat old " - already called that") problems)))
                    ((and (tblsearch "BLOCK" new)
                          (not (member (strcase new) (mapcar 'strcase olds))))
                     (setq problems (cons (strcat old " -> " new
                                                 " - that name is taken") problems)))
                    ;; A name used as both an old and a new name makes the
                    ;; result depend on which happened first.
                    ((and (member (strcase new) (mapcar 'strcase olds))
                          (not (= (strcase new) (strcase old))))
                     (setq problems (cons (strcat old " -> " new
                                                 " - new name is also being renamed")
                                          problems)))
                    (t (setq ok (cons pr ok)))))

            (setq ok (reverse ok) problems (reverse problems))

            ;; --- report -----------------------------------------------------
            (if ok
                (progn
                    (princ "\n\n  WILL RENAME")
                    (foreach pr ok
                        (princ (strcat "\n    " (BRen:Pad (car pr) 24)
                                       " -> " (cdr pr))))))
            (if problems
                (progn
                    (princ "\n\n  WILL SKIP")
                    (foreach s problems (princ (strcat "\n    " s)))))

            (if (null ok)
                (princ "\n\nNothing can be renamed.")
                (progn
                    (initget "Yes No")
                    (setq v (getkword (strcat "\n\nRename these " (itoa (length ok))
                                              " [Yes/No] <Yes>: ")))
                    (if (= "No" v)
                        (princ "\nNothing changed.")
                        (progn
                            (setq n 0)
                            (foreach pr ok
                                (command "_.-RENAME" "_Block" (car pr) (cdr pr))
                                (setq n (1+ n)))
                            (princ (strcat "\n" (itoa n) " block"
                                           (if (= n 1) "" "s") " renamed."))))))))

    (BRen:Restore)
    (princ)
)

(princ)