; -*-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;               Klaus Lörincz CoCreate
;
; SCCS:         %W%
; Description:  Copy a Part which is already in WM to create a clean copy
; Author:       Klaus Loerincz
; Version:      1.2
; Created:      11.06.2001
; Modified:     
; Language:     Lisp
; Package:      custom 
;
; (C) no Copyright
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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


(sd-defdialog 'copy-my-part
	       :dialog-title "Teil NEU aus ALT"
	       :toolbox-button :force
	       :variables
	       '(
		 (teststring :initial-vaue nil)
		 (TEIL
		  :value-type :part
		  :initial-value nil
		  :modifies nil
		  :prompt-text "Bitte einen Teil selektieren um eine Kopie zu erstellen"
		  :after-input 
		  (progn 
		    (setf sco_read_only_db nil)
		    (setf sco_read_only_parent_db nil)
		    (setf teststring (sd-inq-obj-basename TEIL))
		    (setq NAME_NEU (sd-gen-obj-basename :part :parent "/" :prefix
			(if (search "_neu." teststring)
			    (format nil "~A"(subseq teststring 0 (- (length teststring) 1) ))
			  (if (search "." teststring)
			      (format nil "~A~A"(subseq teststring 0 (- (search "." teststring :from-end t) 1) ) "_neu.")
			 (format nil "~A~A" (sd-inq-obj-basename TEIL) "_neu." ))
			 )))
		    (setq sco_partial (sco-ica TEIL "DB-GREF" :PL_LOADMODE ))
		    (setq sco_bgr_flag (sco-ica TEIL "DB-GREF" :PL_PARTIALFLAG)) 
		    (setq sco_read_only_db (sd-inq-obj-flags :SEL-ITEM TEIL :ATTACHMENT :contents :DB-READ-ONLY))
		    (setq sco_read_only_parent_db (sd-inq-obj-flags :SEL-ITEM (sd-inq-parent-obj TEIL) :ATTACHMENT :contents :DB-READ-ONLY))
		    (if (or (string= sco_partial "dummy") (string= sco_bgr_flag "1"))
			(progn
			(setf input (oli:sd-display-warning 
				     "Teil/Baugruppe ist nur partiel geladen"
				     :title "Auswahl ist nicht moeglich"
				     :push-1 "Weiter"
				     :push-2 "Abbrechen"
				     :severity :medium))
			(if (eql input :yes)
			    (progn
			      t
			      )
			  (cancel)
			  )))
		    (if (or (sd-inq-obj-parent-contents-read-only-p TEIL) (string= sco_read_only_db "ON") (string= sco_read_only_parent_db "ON"))
			(progn
			  (sd-set-variable-status 'DEL_ALT :enable nil)
			  (sd-display-warning "Teil kann aus der Baugruppe nicht geloescht werden! - Grund: Baugruppe mit Schreibschutz.")
			  )
		      (if (eq POS_NEU nil)
			  (sd-set-variable-status 'DEL_ALT :enable t))
		      )
		    )
		 )
		 (NAME_NEU
		  :value-type :string
		  :initial-value ""
		  :prompt-text "Bitte geben Sie einen neuen Namen fuer das Teil ein"
		  )
		 (DEL_ALT
		  :title "Altteil loeschen"
		  :value-type :boolean 
                  :toggle-type :wide-toggle
		  :check-function 
		  #'(lambda (value)
		      (if (not TEIL)
			  (values :error "Sie haben noch kein Teil selektiert")
		        (if (not (sd-inq-obj-parent-contents-read-only-p TEIL))
			    :ok
			  (values :error "Teil kann aus der Baugruppe nicht geloescht werden ...(Kein Zugriff auf das Datenbankelemen)")
			  )
			)
		      )
		  :after-input (sd-set-variable-status 'POS_NEU :enable (not DEL_ALT))		 				
		  )
		 (POS_NEU
		  :title "Neuteil positionieren"
		  :value-type :boolean
                  :toggle-type :wide-toggle
		  :after-input (sd-set-variable-status 'DEL_ALT :enable (not POS_NEU))
		  )
		 )
	       :ok-action '(progn
			    (sd-call-cmds (create_multiple_pa :copy :source TEIL :name NAME_NEU ))
			    (let (
                                                (one-obj (sd-pathname-to-obj (format nil "/~A" NAME_NEU)))
                                                (del_list (sd-inq-obj-children (sd-pathname-to-obj (format nil "/~A" NAME_NEU))))
                                                (one_item nil)
                                               )
  			      (when (member "DB-DREF" (sd-inq-item-attributes one-obj :attachment :contents) :test #'string=)
  			        (sd-detach-item-attribute one-obj "DB-DREF" :attachment :contents))
  			      (when (member "DB-PREF" (sd-inq-item-attributes one-obj :attachment :contents) :test #'string=)
 			        (sd-detach-item-attribute one-obj "DB-PREF" :attachment :contents))
			      (when (member "DB-GREF" (sd-inq-item-attributes one-obj :attachment :contents) :test #'string=)
			        (sd-detach-item-attribute one-obj "DB-GREF" :attachment :contents))
			      (when (member "WRL_DEF" (sd-inq-item-attributes one-obj :attachment :contents) :test #'string=)
			        (sd-detach-item-attribute one-obj "WRL_DEF" :attachment :contents))
                                          (when del_list
                                                    (dolist (one_item del_list)
                                                              (sd-call-cmds (DELETE_3D one_item))
                                                     )
                                               )
			    )
			    (if (eq POS_NEU t)
				(mei::put-buffer (format nil "position_pa :part_assembly ~S" (concatenate 'string "/" NAME_NEU ))))
			    (if (eq DEL_ALT t)
				(mei::put-buffer (format nil " delete_3d :part ~S" (sd-inq-obj-pathname TEIL))))
		    )
	       )

      
;;; ======================================================================
;;; Now we inq contents attribute
;;; ======================================================================

(defun sco-ica (obj attr &optional key)
  (sd-inq-item-attribute obj attr (if key key :all) :attachment :contents )
  )