;;; ---------------------------------------------------------------------------
;;; StartupBuilder.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Builds your acaddoc.lsp - the file AutoCAD runs automatically for every
;;; drawing you open.
;;;
;;; Pick your routines from a multi-folder file browser and this writes the
;;; loading expressions for you. Start here when deploying a LISP library to a
;;; team: it is the difference between "load these forty files by hand" and
;;; "everything is just there".
;;;
;;; AUTOLOAD VERSUS LOAD - WHY IT MATTERS
;;; For a .lsp file whose commands can be identified, an AUTOLOAD expression is
;;; written:
;;;
;;;     (autoload "C:/lisp/BFind.lsp" '("BFIND"))
;;;
;;; That does NOT load the file at startup. It registers the command names, and
;;; the file is loaded the first moment someone actually types one. With a
;;; hundred routines that is the difference between AutoCAD starting instantly
;;; and taking several seconds on every drawing.
;;;
;;; A plain LOAD is written only where autoload cannot work - for compiled .vlx
;;; and .fas files, and for any .lsp whose commands cannot be determined:
;;;
;;;     (load "C:/lisp/reactor.lsp" "Failed to load reactor.lsp")
;;;
;;; The second argument is the message shown if the file is missing, which
;;; turns a cryptic startup error into something a colleague can act on.
;;;
;;; WHERE THE FILE GOES
;;; An existing acaddoc.lsp anywhere on the support file search path is
;;; APPENDED to, so your existing startup code is never overwritten. If none
;;; exists, a new one is created in the Support folder under your roamable
;;; profile.
;;;
;;; COMMANDS ARE FOUND WITHOUT LOADING THE FILE
;;; Each .lsp is read as plain text and scanned with a regular expression for
;;; command definitions. No code from the file is ever evaluated, so scanning a
;;; file cannot do anything to your session.
;;;
;;;   STARTUPBUILD  - write loading expressions to acaddoc.lsp
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; StartupBuilder:FixDir
;; ---------------------------------------------------------------------------
;; Normalises a directory path: forward slashes to back, no trailing separator.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:FixDir ( dir )
    (vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:SavePath
;; ---------------------------------------------------------------------------
;; Returns where a new acaddoc.lsp should be created.
;;
;; The Support folder under ROAMABLEROOTPREFIX is the right place: it is
;; already on the support file search path, and on a roaming profile it follows
;; the user between machines. The temp folder is a last resort if that folder
;; does not exist.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:SavePath ( / dir )
    (if (and (setq dir (getvar 'roamablerootprefix))
             (setq dir (strcat (StartupBuilder:FixDir dir) "\\Support"))
             (vl-file-directory-p dir)
        )
        dir
        (StartupBuilder:FixDir (vl-filename-directory (vl-filename-mktemp)))
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:GetCommands
;; ---------------------------------------------------------------------------
;; Returns the command names defined by a LISP file, without loading it.
;;
;; The file is read as text and scanned for:
;;
;;     \(\s*defun\s+c:(\S+)
;;
;; an opening bracket, optional whitespace, "defun", whitespace, "c:", then the
;; run of non-space characters that follows - the command name.
;;
;; TWO COM OBJECTS ARE CREATED AND MUST BE RELEASED
;; AutoLISP has no native regular expressions and no fast whole-file read, so
;; both come from Windows Scripting objects. An unreleased COM object stays in
;; memory for the rest of the AutoCAD session; scanning forty files would leak
;; eighty of them. The release loop therefore runs unconditionally, and the
;; scan is wrapped in a catch so that a failure still reaches it.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:GetCommands ( lsp / err fso mch rgx rtn stm obj )

    (if (and (setq lsp (findfile lsp))
             (setq fso (vlax-create-object "scripting.filesystemobject"))
             (setq rgx (vlax-create-object "vbscript.regexp"))
        )
        (setq err
            (vl-catch-all-apply
               '(lambda ( / str )
                    ;; Mode 1 is read-only; the trailing 0 means ASCII.
                    (setq stm (vlax-invoke-method fso 'opentextfile lsp 1 nil 0)
                          str (vlax-invoke-method stm 'readall)
                    )
                    (vlax-invoke-method stm 'close)

                    (vlax-put-property rgx 'global     actrue)   ; every match
                    (vlax-put-property rgx 'ignorecase actrue)   ; DEFUN or defun
                    (vlax-put-property rgx 'multiline  actrue)
                    (vlax-put-property rgx 'pattern    "\\(\\s*defun\\s+c:(\\S+)")

                    (if (setq mch (vlax-invoke rgx 'execute str))
                        (vlax-for itm mch
                            (vlax-for sub (vlax-get itm 'submatches)
                                (setq rtn (cons sub rtn))
                            )
                        )
                    )
                )
            )
        )
    )

    (foreach obj (list mch stm fso rgx)
        (if (and (= 'vla-object (type obj)) (not (vlax-object-released-p obj)))
            (vlax-release-object obj)
        )
    )

    (if (vl-catch-all-error-p err)
        (progn (princ (strcat "\n  ! could not scan " lsp)) nil)
        (reverse rtn)
    )
)

;;; ===========================================================================
;;; MULTI-FILE, MULTI-FOLDER SELECTION DIALOG
;;;
;;; AutoCAD's getfiled selects ONE file from ONE folder. Building a startup
;;; file usually means gathering routines scattered across several folders, so
;;; the whole of this section exists to provide a two-pane browser: available
;;; files on the left, chosen files on the right, with the folder changeable
;;; between picks so a selection can span directories.
;;; ===========================================================================

;; Fills a list box tile and returns the list, so it can be assigned in one go.
(defun StartupBuilder:ListBox ( key lst )
    (start_list key)
    (foreach x lst (add_list x))
    (end_list)
    lst
)

;; Splits a string on a delimiter.
(defun StartupBuilder:Split ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos)
              (StartupBuilder:Split (substr str (+ pos 1 (strlen del))) del)
        )
        (list str)
    )
)

;; Returns the parent of a directory path.
(defun StartupBuilder:UpDir ( dir )
    (substr dir 1 (vl-string-position 92 dir nil t))
)

;; Removes items from a list by INDEX rather than by value - which is what a
;; list box selection gives, and which correctly handles duplicates.
(defun StartupBuilder:RemoveIndices ( itm lst / idx )
    (setq idx -1)
    (vl-remove-if (function (lambda ( x ) (member (setq idx (1+ idx)) itm))) lst)
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:SplitForSort
;; ---------------------------------------------------------------------------
;; Splits a filename into alternating text and number pieces, so that sorting
;; can compare numbers numerically rather than as text.
;;
;; This is what makes "File2" sort before "File10" instead of after it - plain
;; string comparison puts "1" before "2" and gets it backwards.
;;
;; The technique constructs the TEXT of a LISP list and reads it, which is far
;; faster than assembling the list piece by piece. Character codes: 45 is a
;; hyphen, 46 a full stop, 92 a backslash - all treated as separators; 48 to 57
;; are the digits.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:SplitForSort ( str )
    (   (lambda ( l )
            (read
                (strcat "("
                    (vl-list->string
                        (apply 'append
                            (mapcar
                                (function
                                    (lambda ( a b c )
                                        (cond
                                            ((member b '(45 46 92)) (list 32))
                                            ((< 47 b 58)            (list b))
                                            ((list 32 34 b 34 32))
                                        )
                                    )
                                )
                                (cons nil l) l (append (cdr l) '(( )))
                            )
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list (strcase str))
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:SortList
;; ---------------------------------------------------------------------------
;; Sorts filenames naturally, comparing numeric runs as numbers.
;;
;; The comparison walks both split lists in step until they differ, then
;; decides: a shorter name sorts first, numbers compare numerically, numbers
;; sort before text, and text compares as text.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:SortList ( lst )
    (mapcar (function (lambda ( n ) (nth n lst)))
        (vl-sort-i (mapcar 'StartupBuilder:SplitForSort lst)
            (function
                (lambda ( a b / x y )
                    (while (and (setq x (car a)) (setq y (car b)) (= x y))
                        (setq a (cdr a) b (cdr b))
                    )
                    (cond
                        ((null x) b)
                        ((null y) nil)
                        ((and (numberp x) (numberp y)) (< x y))
                        ((numberp x))
                        ((numberp y) nil)
                        ((< x y))
                    )
                )
            )
        )
    )
)

;; Groups list items by a two-argument predicate.
(defun StartupBuilder:GroupBy ( lst fun / tmp1 tmp2 x1 )
    (if (setq x1 (car lst))
        (progn
            (foreach x2 (cdr lst)
                (if (fun x1 x2)
                    (setq tmp1 (cons x2 tmp1))
                    (setq tmp2 (cons x2 tmp2))
                )
            )
            (cons (cons x1 (reverse tmp1)) (StartupBuilder:GroupBy (reverse tmp2) fun))
        )
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:Sort
;; ---------------------------------------------------------------------------
;; Sorts filenames by extension first, then naturally within each extension -
;; so all the .lsp files appear together, then the .vlx, then the .fas.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:Sort ( lst )
    (apply 'append
        (mapcar 'StartupBuilder:SortList
            (vl-sort
                (StartupBuilder:GroupBy lst
                    (lambda ( a b / x y )
                        (and (setq x (vl-filename-extension a))
                             (setq y (vl-filename-extension b))
                             (= (strcase x) (strcase y))
                        )
                    )
                )
                (function
                    (lambda ( a b / x y )
                        (and (setq x (vl-filename-extension (car a)))
                             (setq y (vl-filename-extension (car b)))
                             (< (strcase x) (strcase y))
                        )
                    )
                )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:CheckRedirect
;; ---------------------------------------------------------------------------
;; Resolves the Windows shell folders that report a localised display name.
;;
;; Under a user profile, "My Documents" is a display name for a folder actually
;; called "Documents" on disk. Browsing into it by its display name finds
;; nothing, so the real name is substituted.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:CheckRedirect ( dir / itm pos )
    (cond
        (   (vl-directory-files dir) dir)
        (   (and (= (strcase (getenv "UserProfile"))
                    (strcase (substr dir 1 (setq pos (vl-string-position 92 dir nil t))))
                 )
                 (setq itm
                     (cdr (assoc (substr (strcase dir t) (+ pos 2))
                                '(("my documents" . "Documents")
                                  ("my pictures"  . "Pictures")
                                  ("my videos"    . "Videos")
                                  ("my music"     . "Music")
                                 )
                          )
                     )
                 )
                 (vl-file-directory-p (setq itm (strcat (substr dir 1 pos) "\\" itm)))
            )
            itm
        )
        (   dir )
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:ListFiles
;; ---------------------------------------------------------------------------
;; Returns what to show in the left-hand pane: subfolders, then matching files,
;; minus anything already chosen.
;;
;; Directory listings are CACHED per folder in dirdata, so browsing back and
;; forth between folders does not re-read them - which matters on a network
;; share where a listing can take a noticeable moment.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:ListFiles ( dir ext lst )
    (vl-remove-if (function (lambda ( x ) (member (strcat dir "\\" x) lst)))
        (cond
            (   (cdr (assoc dir dirdata)))
            (   (cdar
                    (setq dirdata
                        (cons
                            (cons dir
                                (append
                                    ;; Subfolders first. "." is removed; ".." is
                                    ;; kept, and is how the user goes up.
                                    (StartupBuilder:SortList (vl-remove "." (vl-directory-files dir nil -1)))
                                    (StartupBuilder:Sort
                                        (if (member ext '(("") ("*")))
                                            (vl-directory-files dir nil 1)
                                            (vl-remove-if-not
                                                (function
                                                    (lambda ( x / e )
                                                        (and (setq e (vl-filename-extension x))
                                                             (setq e (strcase (substr e 2)))
                                                             (vl-some (function (lambda ( w ) (wcmatch e w))) ext)
                                                        )
                                                    )
                                                )
                                                (vl-directory-files dir nil 1)
                                            )
                                        )
                                    )
                                )
                            )
                            dirdata
                        )
                    )
                )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:ToRelative
;; ---------------------------------------------------------------------------
;; Returns a path expressed relative to a directory, for display in the
;; right-hand pane - a full path would be too wide to read.
;;
;; It walks both paths in step while they agree, then emits ".." for each
;; remaining level of the base directory. A path on a different DRIVE cannot be
;; expressed relatively at all, so it is returned in full.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:ToRelative ( dir path / p q )
    (setq dir (vl-string-right-trim "\\" dir))
    (cond
        ;; Different drive letters - no relative path exists.
        (   (and (setq p (vl-string-position 58  dir))
                 (setq q (vl-string-position 58 path))
                 (/= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            path
        )
        ;; A shared leading folder - strip it from both and recurse.
        (   (and (setq p (vl-string-position 92  dir))
                 (setq q (vl-string-position 92 path))
                 (= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
            )
            (StartupBuilder:ToRelative (substr dir (+ 2 p)) (substr path (+ 2 q)))
        )
        ;; The base is exhausted and the path continues below it.
        (   (and (setq q (vl-string-position 92 path))
                 (= (strcase dir) (strcase (substr path 1 q)))
            )
            (strcat ".\\" (substr path (+ 2 q)))
        )
        (   (= "" dir) path)
        ;; Still base levels to climb.
        (   (setq p (vl-string-position 92 dir))
            (StartupBuilder:ToRelative (substr dir (+ 2 p)) (strcat "..\\" path))
        )
        (   (StartupBuilder:ToRelative "" (strcat "..\\" path)))
    )
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:BrowseForFolder
;; ---------------------------------------------------------------------------
;; The Windows folder browser. Every COM object obtained is released, in every
;; circumstance, or each use would leak three.
;; ---------------------------------------------------------------------------
(defun StartupBuilder:BrowseForFolder ( msg dir flg / err fld pth shl slf )
    (setq err
        (vl-catch-all-apply
            (function
                (lambda ( / app hwd )
                    (if (setq app (vlax-get-acad-object)
                              shl (vla-getinterfaceobject app "shell.application")
                              hwd (vl-catch-all-apply 'vla-get-hwnd (list app))
                              fld (vlax-invoke-method shl 'browseforfolder
                                      (if (vl-catch-all-error-p hwd) 0 hwd) msg flg dir)
                        )
                        (setq slf (vlax-get-property fld 'self)
                              pth (StartupBuilder:FixDir (vlax-get-property slf 'path))
                        )
                    )
                )
            )
        )
    )
    (if slf (vlax-release-object slf))
    (if fld (vlax-release-object fld))
    (if shl (vlax-release-object shl))
    (if (vl-catch-all-error-p err)
        (progn (princ (vl-catch-all-error-message err)) nil)
        pth
    )
)

;; Convenience wrappers used by the dialog's action expressions.
(defun StartupBuilder:UpdateFiles ( dir ext lst )
    (StartupBuilder:ListBox "box1" (StartupBuilder:ListFiles dir ext lst))
)

(defun StartupBuilder:UpdateChosen ( dir lst )
    (StartupBuilder:ListBox "box2"
        (mapcar (function (lambda ( x ) (StartupBuilder:ToRelative dir x))) lst)
    )
    lst
)

;; ---------------------------------------------------------------------------
;; StartupBuilder:GetFiles
;; ---------------------------------------------------------------------------
;; The two-pane file browser. Returns the chosen full paths, or nil.
;;
;; The dialog name "startupfiles" must match between the DCL and new_dialog.
;;
;; Note the temporary variable used by the Browse action was left undeclared in
;; the original, leaking globally; it is localised here.
;;
;; msg - [str] dialog title
;; def - [str] starting folder; the drawing's folder if empty
;; ext - [str] extension filter, e.g. "lsp;vlx;fas"
;; ---------------------------------------------------------------------------
(defun StartupBuilder:GetFiles ( msg def ext / *error* dch dcl des dir dirdata lst rtn tmp )

    (defun *error* ( msg )
        (if (= 'file (type des)) (close des))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (findfile dcl)) (vl-file-delete dcl))
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** file selection error: " msg " **"))
        )
        (princ)
    )

    (if (and
            (setq dcl (vl-filename-mktemp nil nil ".dcl"))
            (setq des (open dcl "w"))
            (progn
                (foreach x
                   '(
                        "lst : list_box"
                        "{"
                        "    width = 40.0; height = 20.0;"
                        "    fixed_width = true; fixed_height = true;"
                        "    alignment = centered; multiple_select = true;"
                        "}"
                        "but : button"
                        "{"
                        "    width = 20.0; height = 1.8;"
                        "    fixed_width = true; fixed_height = true;"
                        "    alignment = centered;"
                        "}"
                        "startupfiles : dialog"
                        "{"
                        "    key = \"title\"; spacer;"
                        "    : row"
                        "    {"
                        "        alignment = centered;"
                        "        : edit_box { key = \"dir\"; label = \"Folder:\"; }"
                        "        : button { key = \"brw\"; label = \"Browse\"; fixed_width = true; }"
                        "    }"
                        "    spacer;"
                        "    : row"
                        "    {"
                        "        : column"
                        "        {"
                        "            : lst { key = \"box1\"; }"
                        "            : but { key = \"add\"; label = \"Add Files\"; }"
                        "        }"
                        "        : column"
                        "        {"
                        "            : lst { key = \"box2\"; }"
                        "            : but { key = \"del\"; label = \"Remove Files\"; }"
                        "        }"
                        "    }"
                        "    spacer; ok_cancel;"
                        "}"
                    )
                    (write-line x des)
                )
                (setq des (close des))
                (< 0 (setq dch (load_dialog dcl)))
            )
            (new_dialog "startupfiles" dch)
        )
        (progn
            (setq ext (if (= 'str (type ext))
                          (StartupBuilder:Split (strcase ext) ";")
                         '("*")
                      )
            )
            (set_tile "title" (if (member msg '(nil "")) "Select Files" msg))
            (set_tile "dir"
                (setq dir (StartupBuilder:FixDir
                              (if (or (member def '(nil ""))
                                      (not (vl-file-directory-p (StartupBuilder:FixDir def)))
                                  )
                                  (getvar 'dwgprefix)
                                  def
                              )
                          )
                )
            )
            (setq lst (StartupBuilder:UpdateFiles dir ext nil))

            ;; Both buttons start disabled - nothing is selected yet.
            (mode_tile "add" 1)
            (mode_tile "del" 1)

            (action_tile "brw"
                (vl-prin1-to-string
                   '(if (setq tmp (StartupBuilder:BrowseForFolder "" nil 512))
                        (setq lst (StartupBuilder:UpdateFiles (set_tile "dir" (setq dir tmp)) ext rtn)
                              rtn (StartupBuilder:UpdateChosen dir rtn)
                        )
                    )
                )
            )

            ;; $reason 1 means the user pressed Enter in the edit box rather
            ;; than merely tabbing out of it.
            (action_tile "dir"
                (vl-prin1-to-string
                   '(if (= 1 $reason)
                        (setq lst (StartupBuilder:UpdateFiles
                                      (set_tile "dir" (setq dir (StartupBuilder:FixDir $value))) ext rtn)
                              rtn (StartupBuilder:UpdateChosen dir rtn)
                        )
                    )
                )
            )

            ;; Left pane. $reason 4 is a double-click: on ".." go up, on a
            ;; folder go into it, on files add them. A single click merely
            ;; enables or disables the Add button.
            (action_tile "box1"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm tmp )
                            (if (setq itm (mapcar (function (lambda ( n ) (nth n lst)))
                                                  (read (strcat "(" $value ")"))))
                                (if (= 4 $reason)
                                    (cond
                                        (   (equal '("..") itm)
                                            (setq lst (StartupBuilder:UpdateFiles
                                                          (set_tile "dir" (setq dir (StartupBuilder:UpDir dir))) ext rtn)
                                                  rtn (StartupBuilder:UpdateChosen dir rtn)
                                            )
                                        )
                                        (   (vl-file-directory-p
                                                (setq tmp (StartupBuilder:CheckRedirect (strcat dir "\\" (car itm))))
                                            )
                                            (setq lst (StartupBuilder:UpdateFiles
                                                          (set_tile "dir" (setq dir tmp)) ext rtn)
                                                  rtn (StartupBuilder:UpdateChosen dir rtn)
                                            )
                                        )
                                        (   (setq rtn (StartupBuilder:Sort
                                                          (append rtn (mapcar (function (lambda ( x ) (strcat dir "\\" x))) itm)))
                                                  rtn (StartupBuilder:UpdateChosen dir rtn)
                                                  lst (StartupBuilder:UpdateFiles dir ext rtn)
                                            )
                                        )
                                    )
                                    ;; Add is only meaningful if at least one
                                    ;; non-folder is selected.
                                    (if (vl-every (function (lambda ( x ) (vl-file-directory-p (strcat dir "\\" x)))) itm)
                                        (mode_tile "add" 1)
                                        (mode_tile "add" 0)
                                    )
                                )
                            )
                        )
                    )
                )
            )

            ;; Right pane: double-click removes.
            (action_tile "box2"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm (mapcar (function (lambda ( n ) (nth n rtn)))
                                                  (read (strcat "(" $value ")"))))
                                (if (= 4 $reason)
                                    (setq rtn (StartupBuilder:UpdateChosen dir (vl-remove (car itm) rtn))
                                          lst (StartupBuilder:UpdateFiles dir ext rtn)
                                    )
                                    (mode_tile "del" 0)
                                )
                            )
                        )
                    )
                )
            )

            (action_tile "add"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm (vl-remove-if 'vl-file-directory-p
                                              (mapcar (function (lambda ( n ) (nth n lst)))
                                                      (read (strcat "(" (get_tile "box1") ")")))
                                          )
                                )
                                (setq rtn (StartupBuilder:Sort
                                              (append rtn (mapcar (function (lambda ( x ) (strcat dir "\\" x))) itm)))
                                      rtn (StartupBuilder:UpdateChosen dir rtn)
                                      lst (StartupBuilder:UpdateFiles dir ext rtn)
                                )
                            )
                            (mode_tile "add" 1)
                            (mode_tile "del" 1)
                        )
                    )
                )
            )

            (action_tile "del"
                (vl-prin1-to-string
                   '(
                        (lambda ( / itm )
                            (if (setq itm (read (strcat "(" (get_tile "box2") ")")))
                                (setq rtn (StartupBuilder:UpdateChosen dir (StartupBuilder:RemoveIndices itm rtn))
                                      lst (StartupBuilder:UpdateFiles dir ext rtn)
                                )
                            )
                            (mode_tile "add" 1)
                            (mode_tile "del" 1)
                        )
                    )
                )
            )

            (if (zerop (start_dialog))
                (setq rtn nil)
            )
        )
    )

    (*error* nil)
    rtn
)

;; ---------------------------------------------------------------------------
;; c:STARTUPBUILD  -  main routine
;; ---------------------------------------------------------------------------
(defun c:STARTUPBUILD ( / *error* vars vals cmd des lst out auto plain )

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

    (defun StartupBuilder:Restore ( )
        ;; A file handle left open would lock acaddoc.lsp for the rest of the
        ;; session - and that is the one file you least want locked.
        (if (= 'file (type des)) (close des))
        (mapcar 'setvar vars vals)
        (princ)
    )

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

    (setvar "CMDECHO" 0)

    (cond
        (   (not (setq lst (StartupBuilder:GetFiles "Select Program Files" "" "lsp;vlx;fas")))
            (princ "\n*Cancelled*")
        )

        ;; Append to an existing acaddoc.lsp if one is on the search path,
        ;; otherwise create a new one. Appending matters - overwriting would
        ;; silently destroy whatever startup code was already there.
        (   (not (cond
                    (   (setq out (findfile "acaddoc.lsp"))
                        (setq des (open out "a"))
                    )
                    (   (setq out (strcat (StartupBuilder:SavePath) "\\acaddoc.lsp"))
                        (setq des (open out "w"))
                    )
                 )
            )
            (princ (strcat "\nUnable to open \"" out "\" for writing."))
        )

        (   t
            (setq auto 0 plain 0)
            (foreach fnm lst
                ;; Forward slashes, so the path needs no escaping when written
                ;; into a LISP string.
                (setq fnm (vl-string-translate "\\" "/" fnm))
                (cond
                    ;; A .lsp whose commands could be identified gets autoload.
                    (   (and (= ".lsp" (strcase (vl-filename-extension fnm) t))
                             (setq cmd (StartupBuilder:GetCommands fnm))
                        )
                        (write-line
                            (strcat "(autoload " (vl-prin1-to-string fnm)
                                    " '" (vl-prin1-to-string cmd) ")")
                            des
                        )
                        (setq auto (1+ auto))
                        (princ (strcat "\n  autoload  " (vl-filename-base fnm)
                                       "  (" (itoa (length cmd)) " command"
                                       (if (= 1 (length cmd)) "" "s") ")"))
                    )
                    ;; Everything else gets a plain load, with a failure message.
                    (   (write-line
                            (strcat "(load " (vl-prin1-to-string fnm)
                                    " \"Failed to load " (vl-filename-base fnm)
                                    (vl-filename-extension fnm) "\")")
                            des
                        )
                        (setq plain (1+ plain))
                        (princ (strcat "\n  load      " (vl-filename-base fnm)
                                       (vl-filename-extension fnm)))
                    )
                )
            )

            ;; A trailing (princ) keeps the startup file quiet - without it the
            ;; last expression's value is echoed at every drawing open.
            (write-line "(princ)" des)
            (setq des (close des))

            (princ (strcat "\n\n" (itoa (length lst))
                           " load expression" (if (cdr lst) "s" "")
                           " written to " out
                           "\n  " (itoa auto) " demand-loaded, " (itoa plain) " loaded at startup."
                   )
            )
        )
    )

    (StartupBuilder:Restore)
    (princ)
)

(princ)