;;--------------------------------------------------------------------------*
;;  Copyright 20049  DC4 Technisches Büro GmbH                               *
;;                                                                          *
;;--------------------------------------------------------------------------*
;;  Dateiname: teilname.lsp
;;  Version  : 1.0
;;  Datum    : 26.01.2004
;;  Author   : Gt
;;--------------------------------------------------------------------------*

(in-package :custom)
(use-package :OLI)

;;--------------------------------------------------------------------------*

(sd-defdialog 'dc4-desman-inhid-to-basename-dialog
:dialog-title "IDs=>Namen"
;;:dialog-control :sequential
:variables
  '(
    (wahl
           :selection
              (*sd-object-seltype*)
           :multiple-items t
           :size :third
           :show-select-menu t
           :prompt-text "Teil oder Baugruppe angeben"
           :title "Teil"
           :initial-value nil
           :check-function #'(lambda (para) (if nil :ok :err))
           :confirmation
             (:Err :dialog :warning
                   :prompt (format nil "Alle Teile und Baugruppen werden~%~%entsprechend ihren Inhalts-IDs umbenannt!")
                   :severity :high
                   :cancel-cleanup (cancel)
             )
    )
    (alle  :value-type :boolean
           :toggle-type :wide-toggle
           :title "Alle umbenennen"
           :initial-value nil
    )
    (next
           :push-action (sd-call-cmds (next-action))
    )
   )
:local-functions
  '((next-action ()
     (let ()
      (dolist (kind wahl)
       (dc4-inhid-to-basename-in-bgr kind alle)
      );;dolist
     )
    )
   )
:ok-action
   '(sd-call-cmds (next-action))
)

(defun dc4-inhid-to-basename-in-bgr (teil_bgr alle)
 (let (basename owner pathname inhid basename newpath kind kinder)
  (setf basename (sd-inq-obj-basename teil_bgr))
;;(display basename)
  (when (or (sd-inq-part-p teil_bgr)
            (sd-inq-assembly-p teil_bgr)
            (sd-inq-container-p teil_bgr)
        )
   (progn
    (setf pathname (sd-inq-obj-pathname teil_bgr))
    (when (sd-string/= pathname "/")
     (progn
      (setf inhid (sd-inq-obj-contents-name teil_bgr))
      (setf owner (sd-inq-parent-obj teil_bgr))
      (when (not owner)
        (setf owner (sd-pathname-to-obj "/"))
      );;when
      (when inhid
       (progn
;;(display pathname)
        (setf newname (dc4-gen-part-basename owner teil_bgr inhid))
;;(display newname)
        (when (or (and (sd-inq-part-p teil_bgr) (sd-string-match-pattern-p "[tT][0-9]*" basename))
                  (and (sd-inq-assembly-p teil_bgr) (sd-string-match-pattern-p "[bB][0-9]*" basename))
                  (and (sd-inq-container-p teil_bgr) (sd-string-match-pattern-p "[bB][hH][0-9]*" basename))
                  alle
              )
         (progn
          (if (not (sd-inq-obj-parent-contents-read-only-p teil_bgr))
           (sd-call-cmds (CHANGE_NAME_PA :PART_ASMB pathname :NAME newname))
           (display (format nil "~a konnte nicht umbenannt werden" pathname))
          );;if
         );;progn
        );;when
       );;progn
      );;when
     );;progn
    );;when
    (setf kinder (sd-inq-obj-children teil_bgr))
    (dolist (kind kinder)
       (dc4-inhid-to-basename-in-bgr kind alle)
    ) ;; dolist
   );;progn
  );;when
 ) ;; let
)

(defun dc4-gen-part-basename (owner teil_bgr prefix)
 (let (baslist chlist ch teiletyp bas index name)
  (setf baslist (list))
;;(display owner)
  (setf chlist (sd-inq-obj-children owner))
  (dolist (ch chlist)
   (when (or (sd-inq-part-p ch) (sd-inq-assembly-p ch) (sd-inq-container-p ch))
    (progn
     (when (not (equal ch teil_bgr))
      (progn
;;(display (sd-inq-obj-pathname teil_bgr))
       (setf bas (sd-inq-obj-basename ch))
       (setf baslist (nconc baslist (list bas)))
      );;progn
     );;when
    );;progn
   );;when
  );;dolist
  (setf index 0)
;;(display baslist)
  (loop
   (setf index (+ index 1))
   (if (= index 1)
    (setf name prefix)
    (setf name (format nil "~a.~a" prefix index))
   );;if
   (if (not (member name baslist :test #'equal)) (return t))
  );;loop
  (values name)
 );;let
)