- (let* ((d (get-fkey-data instance (slot-name slot)))
- (finstance (car d))
- (foreign-slot-name (cdr d))
- (new-instance
- (call-component
- (parent slot)
- (make-instance 'mewa::mewa-presentation-search
- :search-presentation
- (mewa:make-presentation finstance
- :type :search-presentation)
- :list-presentation
- (mewa:make-presentation finstance
- :type :listing)))))
- (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
- (meta-model:sync-instance instance)
- (clsql:update-objects-joins (list instance))))
-
+ (multiple-value-bindf (finstance foreign-slot-name)
+ (meta-model:explode-foreign-key instance (slot-name slot))
+ (let ((new-instance
+ (call-component
+ (parent slot)
+ (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
+ 'mewa::mewa-presentation-search)
+ :search-presentation
+ (mewa:make-presentation finstance
+ :type :search-presentation)
+ :list-presentation
+ (mewa:make-presentation finstance
+ :type :listing)))))
+ (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
+ (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
+
+(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
+ (multiple-value-bindf (finstance foreign-slot-name)
+ (meta-model:explode-foreign-key instance (slot-name slot))
+ (let ((new-instance
+ (call-component
+ (parent slot)
+ (mewa:make-presentation finstance :type (creator self)))))
+
+ ;;;; TODO: this next bit is due to a bad design decision.
+ ;;;; Components should always have (ok) return self, but somewhere
+ ;;;; i've made in return (instance self) sometimes, and this
+ ;;;; bahaviour is totatlly fucked.
+
+ (when (typep new-instance 'mewa::mewa)
+ (setf new-instance (instance new-instance)))
+
+ ;;;; sorry about that, and now back t our regular program.
+
+ (meta-model:sync-instance new-instance)
+ (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
+ (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
+
+