1 files changed, 7 insertions, 170 deletions
diff --git a/examples/mux.lisp b/examples/mux.lisp
index 498846a5f..0ffb32427 100644..100755
--- a/examples/mux.lisp
+++ b/examples/mux.lisp
@@ -1,173 +1,10 @@
+#!/usr/bin/run-lisp-trans
+;
+; settrans -ac foo ./mux.lisp file-list command
+;
 
-(defpackage :mux-translator
-  (:use :cl :hurd-common :mach
-        :hurd :hurd-translator
-        :hurd-tree-translator
-        :split-sequence))
+(unless (= (length ext:*args*) 2)
+  (error "Argument syntax: <file list> <classification command>"))
 
-(in-package :mux-translator)
-
-(defconstant +file-list+ (first ext:*args*))
-(defconstant +class-command+ (second ext:*args*))
-
-(defclass mux-translator (tree-translator)
-  ((timestamp :initform nil
-              :initarg :timestamp
-              :accessor timestamp)))
-
-(defclass mux-entry (entry)
-  ((port :initarg :port
-         :initform nil
-         :accessor port)))
-
-(define-callback read-file mux-translator
-                 (node user start amount stream)
-  (when (has-access-p node user :read)
-    (let ((data (io-read (port node)
-                         :amount amount
-                         :offset start)))
-      (when data
-        (write-sequence data stream))
-      t)))
-
-(define-callback write-file mux-translator
-                 (node user offset stream amount)
-  (unless (has-access-p node user :write)
-    (return-from write-file nil))
-  (when (is-dir-p (stat node))
-    (return-from write-file :is-a-directory))
-  (let ((arr (make-array amount :element-type '(unsigned-byte 8))))
-    (read-sequence arr stream)
-    (let ((ret (io-write (port node)
-                         arr
-                         :offset offset)))
-      (cond
-        ((numberp ret)
-         (setf (stat node) (io-stat (port node)))
-         t)
-        (t ret)))))
-
-(define-callback file-change-size mux-translator
-                 (node user new-size)
-  (when (is-dir-p (stat node))
-    (return-from file-change-size :is-a-directory))
-  (unless (has-access-p node user :write)
-    (return-from file-change-size :operation-denied))
-  (let ((err (file-set-size (port node) new-size)))
-    (when (eq err t)
-      (setf (stat node) (io-stat (port node))))
-    err))
-
-(define-callback create-directory mux-translator
-                 (node user name mode)
-  (declare (ignore node user name mode))
-  nil)
-
-(define-callback remove-directory-entry mux-translator
-				 (node user name)
-  (declare (ignore node user name))
-  nil)
-
-(define-callback create-hard-link mux-translator
-                 (dir user file name)
-  (declare (ignore dir user file name))
-  nil)
-
-(define-callback file-rename mux-translator
-                 (user old-dir old-name new-dir new-name)
-  (declare (ignore user old-dir old-name new-dir new-name))
-  nil)
-
-(define-callback allow-link-p mux-translator
-                 (node user)
-  (declare (ignore node user))
-  nil)
-
-(define-callback create-symlink mux-translator
-                 (node user target)
-  (declare (ignore node user target))
-  nil)
-
-(define-callback refresh-node mux-translator
-                 (node user)
-  (declare (ignore node user))
-  (let ((new-timestamp (get-timestamp)))
-    (when (time-value-newer-p new-timestamp (timestamp translator))
-      (let ((root (root *translator*)))
-        (clear-dir root)
-        (mirror-file-list root)
-        (setf (timestamp *translator*) new-timestamp)
-        t))))
-
-(defun read-file-lines (file)
-  "Return a list of lines in file 'file'."
-  (with-open-file (stream file)
-    (loop for line = (read-line stream nil)
-          while line
-          collect line)))
-
-(defun classify-node (file)
-  (let ((cmd (concatenate-string +class-command+ " " file)))
-    (with-stream (stream
-                   (ext:make-pipe-input-stream cmd))
-      (split-sequence #\/ (read-line stream nil)))))
-
-(defun file-basename (file)
-  (first (last
-           (split-sequence #\/ file))))
-
-(defun mirror-file (node dir-list full-name name port)
-  (let ((last-p (null dir-list)))
-    (cond
-      (last-p
-        (let ((file-stat (io-stat port)))
-          (let ((entry (make-instance 'mux-entry
-                                      :stat file-stat
-                                      :parent node
-                                      :port port)))
-            (tg:finalize entry (lambda () (port-deallocate port)))
-            (add-entry node entry name))))
-      (t
-        (let ((dir-name (first dir-list))
-              (rest-dir-name (rest dir-list)))
-          (let ((found (get-entry node dir-name)))
-            (cond
-              ((and found
-                    (not (is-dir-p (stat found))))
-               (warn "~s could not be classified" full-name)
-               (port-deallocate port)
-               (return-from mirror-file nil))
-              ((not found)
-               (setf found (make-instance 'dir-entry
-                                          :parent node
-                                          :stat (make-stat (stat node))))
-               (add-entry node found dir-name)))
-            (mirror-file found rest-dir-name full-name name port)))))))
-
-(defun mirror-file-list (node)
-  (loop for file in (read-file-lines +file-list+)
-        do (let ((port (file-name-lookup file
-                                         :flags '(:read :write :exec))))
-             (when (port-valid-p port)
-               (mirror-file node
-                            (classify-node file)
-                            file
-                            (file-basename file)
-                            port)))))
-
-(define-callback fill-root-node mux-translator
-                 ((node dir-entry))
-  (mirror-file-list node))
-
-(defun get-timestamp ()
-  (with-port-deallocate (port (file-name-lookup +file-list+ :flags '(:read :notrans)))
-    (stat-get (io-stat port) 'st-mtime)))
-
-(defun main ()
-  (let ((translator (make-instance 'mux-translator
-                                   :name "mux-translator"
-                                   :timestamp (get-timestamp))))
-    (run-translator translator)))
-
-(main)
+(asdf:operate 'asdf:load-op 'mux-translator)