Add feature get-focus-object (C-x P)

scheme/browse-directory-list.scm

@@ -218,6 +218,23 @@
 	       prepare-selection-for-command-mode)
 	   file-names)))
 
+      (define (make-focus-object-reference table obj)
+	(let ((id (add-focus-object table obj)))
+	  `(focus-value ,id)))
+
+      (define (get-focus-object self focus-object-table)
+	(let ((marked (select-list-get-selection select-list))
+	      (make-reference (lambda (obj)
+				(make-focus-object-reference 
+				 focus-object-table obj))))
+	  (if (null? marked)
+	      (exp->string 
+	       (make-reference (select-list-selected-entry select-list)))
+	      (string-append
+	       "(list " 
+	       (string-join (map exp->string (map make-reference marked)))
+	       ")"))))
+
       (lambda (message)
 	(cond
 	 ((eq? message 'paint)
@@ -232,6 +249,9 @@
 	 ((eq? message 'get-selection)
 	  get-selection)
 
+	 ((eq? message 'get-focus-object)
+	  get-focus-object)
+       
 	 (else
 	  (error "fsobjects-viewer unknown message" message)))))))
 

scheme/focus.scm

@@ -0,0 +1,18 @@
+(define-record-type focus-table :focus-table
+  (really-make-focus-table table count)
+  focus-table?
+  (table focus-table-table)
+  (count focus-table-count set-focus-table-count!))
+
+(define (make-empty-focus-table)
+  (really-make-focus-table (make-integer-table) 0))
+
+(define (add-focus-object focus-table object)
+  (let ((count (+ 1 (focus-table-count focus-table))))
+    (table-set! 
+     (focus-table-table focus-table) count object)
+    count))
+
+(define (get-focus-object focus-table index)
+  (table-ref (focus-table-table focus-table) index))
+

scheme/nuit-engine.scm

@@ -51,6 +51,8 @@
 (define executable-completions-lock (make-lock))
 (define executable-completions #f)
 
+(define focus-table (make-empty-focus-table))
+
 (define key-control-x 24)
 (define key-o 111)
 (define key-tab 9)
@@ -281,6 +283,24 @@
 ;; #### crufty
 (define split-command-line string-tokenize)
 
+(define (paste-selection/refresh viewer)
+  (add-string-to-command-buffer
+   (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?)))
+  (print-command-buffer (app-window-curses-win command-window)
+			command-buffer)
+  (move-cursor command-buffer result-buffer)
+  (refresh-command-window))
+
+(define (paste-focus-object/refresh viewer)
+  (add-string-to-command-buffer
+   (if (command-buffer-in-command-mode?)
+       (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?))
+       (send (current-viewer) 'get-focus-object focus-table)))
+  (print-command-buffer (app-window-curses-win command-window)
+			command-buffer)
+  (move-cursor command-buffer result-buffer)
+  (refresh-command-window))
+
 ;; handle input
 (define (run)
 
@@ -342,27 +362,15 @@
       (loop (wait-for-input) #f #f))
 
      ;; C-x p --- insert selection
-     ((and c-x-pressed? 
-	   (focus-on-command-buffer?)
-	   (current-history-item)
+     ((and c-x-pressed? (current-history-item)
 	   (= ch 112))
-      (add-string-to-command-buffer
-       (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?)))
-      (print-command-buffer (app-window-curses-win command-window)
-			    command-buffer)
-      (move-cursor command-buffer result-buffer)
-      (refresh-command-window)
+      (paste-selection/refresh (current-viewer))
       (loop (wait-for-input) #f #f))
 
-     ((and c-x-pressed? (focus-on-result-buffer?)
-	   (= ch 112))
-      (add-string-to-command-buffer
-       (send (current-viewer) 'get-selection (command-buffer-in-scheme-mode?)))
-      (focus-command-buffer!)
-      (print-command-buffer (app-window-curses-win command-window)
-			    command-buffer)
-      (move-cursor command-buffer result-buffer)
-      (refresh-command-window)
+     ;; C-x P --- insert focus object(s)
+     ((and c-x-pressed? (current-history-item)
+	   (= ch 80))
+      (paste-focus-object/refresh (current-viewer))
       (loop (wait-for-input) #f #f))
 
      ((and c-x-pressed? (focus-on-result-buffer?))

scheme/nuit-packages.scm

@@ -118,6 +118,7 @@
 	signals
         let-opt
 
+	focus-table
 	objects
 	layout
 	fs-object
@@ -287,16 +288,16 @@
 
 ;;; focus table
 
-; (define-interface focus-table-interface
-;   (export make-empty-focus-table
-; 	  add-focus-object
-; 	  get-focus-object))
+(define-interface focus-table-interface
+  (export make-empty-focus-table
+ 	  add-focus-object
+ 	  get-focus-object))
 
-; (define-structure focus-table focus-table-interface
-;   (open scheme
-; 	define-record-types
-; 	general-table)
-;   (files focus))
+(define-structure focus-table focus-table-interface
+   (open scheme
+ 	define-record-types
+ 	tables)
+   (files focus))
 
 ;;; completion-sets
 
@@ -339,6 +340,7 @@
 	rt-modules
 	tty-debug
 
+	focus-table
 	fs-object
 	objects
 	plugin