;;; ---------------------------------------------------------------------------
;;; PropSiphon.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Reverse MATCHPROP - siphons properties OFF an existing object and makes them
;;; the current drawing defaults.
;;;
;;; MATCHPROP pushes the properties of a source object onto other objects.
;;; This does the opposite: it reads colour, layer, linetype, lineweight and
;;; linetype scale from one picked object and sets CECOLOR / CLAYER / CELTYPE /
;;; CELWEIGHT / CELTSCALE, so everything you draw NEXT inherits them.
;;;
;;; A DXF group is only applied when the object actually carries it. An object
;;; set to BYLAYER simply has no group 62/6/370/48 entry, and in that case the
;;; corresponding default is deliberately left alone rather than being forced.
;;;
;;; COMMAND:  SIPHON  - adopt a picked object's properties as current
;;; ---------------------------------------------------------------------------

;; ---------------------------------------------------------------------------
;; c:SIPHON  -  main routine
;; ---------------------------------------------------------------------------
(defun c:SIPHON ( / *error* vars vals ent data value applied )

    ;; -----------------------------------------------------------------------
    ;; The five defaults this routine overwrites. Captured on entry purely so
    ;; the error path can roll them back - a half-applied set of defaults is
    ;; worse than none at all.
    ;; -----------------------------------------------------------------------
    (setq vars '("CECOLOR" "CLAYER" "CELTYPE" "CELWEIGHT" "CELTSCALE")
          vals (mapcar 'getvar vars)
    )

    ;; -----------------------------------------------------------------------
    ;; Roll the drawing defaults back to their incoming values. Only used by
    ;; the error handler; a successful run intentionally leaves them changed,
    ;; because changing them is the whole point of the command.
    ;; -----------------------------------------------------------------------
    (defun PropSiphon:Restore ( )
        (mapcar 'setvar vars vals)
        (princ)
    )

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

    ;; -----------------------------------------------------------------------
    ;; entsel returns (<ename> <pick point>) or nil if nothing was picked, so
    ;; the car is only safe behind this test.
    ;; -----------------------------------------------------------------------
    (if (setq ent (entsel "\nSelect object to siphon properties from: "))
        (progn
            (setq data    (entget (car ent))
                  applied nil
            )

            ;; ---------------------------------------------------------------
            ;; Colour - DXF 62, an integer ACI index. Absent when BYLAYER.
            ;; ---------------------------------------------------------------
            (if (setq value (cdr (assoc 62 data)))
                (progn (setvar "CECOLOR" (itoa value))
                       (setq applied (cons "colour" applied))
                )
            )

            ;; ---------------------------------------------------------------
            ;; Layer - DXF 8. Always present on a valid entity.
            ;; ---------------------------------------------------------------
            (if (setq value (cdr (assoc 8 data)))
                (progn (setvar "CLAYER" value)
                       (setq applied (cons "layer" applied))
                )
            )

            ;; ---------------------------------------------------------------
            ;; Linetype - DXF 6. Absent when BYLAYER.
            ;; ---------------------------------------------------------------
            (if (setq value (cdr (assoc 6 data)))
                (progn (setvar "CELTYPE" value)
                       (setq applied (cons "linetype" applied))
                )
            )

            ;; ---------------------------------------------------------------
            ;; Lineweight - DXF 370, in hundredths of a millimetre. The two
            ;; negative sentinels mean BYLAYER (-1) and BYBLOCK (-2); neither
            ;; is a real width, so neither is adopted as a default.
            ;; ---------------------------------------------------------------
            (if (and (setq value (cdr (assoc 370 data)))
                     (<= 0 value)
                )
                (progn (setvar "CELWEIGHT" value)
                       (setq applied (cons "lineweight" applied))
                )
            )

            ;; ---------------------------------------------------------------
            ;; Linetype scale - DXF 48. Must be positive to be meaningful.
            ;; ---------------------------------------------------------------
            (if (and (setq value (cdr (assoc 48 data)))
                     (< 0.0 value)
                )
                (progn (setvar "CELTSCALE" value)
                       (setq applied (cons "ltscale" applied))
                )
            )

            ;; ---------------------------------------------------------------
            ;; Report what was actually adopted. Anything not listed was
            ;; BYLAYER on the source object and has been left untouched.
            ;; ---------------------------------------------------------------
            (if applied
                (princ (strcat "\nAdopted as current: "
                               (apply 'strcat
                                      (cons (car (reverse applied))
                                            (mapcar '(lambda ( x ) (strcat ", " x))
                                                    (cdr (reverse applied))
                                            )
                                      )
                               )
                       )
                )
                (princ "\nObject is BYLAYER throughout - no defaults changed.")
            )
        )
        (princ "\n*Cancelled* - no object selected.")
    )

    (princ)
)

(princ)