;;; -*- Mode:LISP; Package:KERMIT; Base:8; Readtable:ZL -*- ;;Copyright LISP Machine, Inc. 1984, 1985 ,1986 ;; See filename "Copyright" for ;;licensing and release information. (declare (special interaction-pane *filnam* *filelist* *serial-stream* *terminal*)) ;;;; G N X T F L ;moved here from file kermit-window; 6-21-84 --mhd (DEFUN GNXTFL () "Get next file in a file group. Set *FILNAM* to next file, and return rest of *FILELIST*." (AND *DEBUG* (DEBUGGER-TELL-USER ':GNXTFL *FILELIST*)) (without-interrupts (setq *filnam* (car *filelist*)) (setq *filelist* (cdr *filelist*))) (cond ((consp *filnam*) (setq *as-filnam* (cadr *filnam*) *filnam* (car *filnam*)))) *filnam*) (defconst kermit-default-pathname :unbound) (defun kermit-filelist (filename) (let ((pathname (fs:parse-pathname (fs:merge-pathname-defaults filename kermit-default-pathname)))) ;; must be parsable pathname (cond ((eq (send pathname ':send-if-handles ':directory) ':unspecific) ;; some device or other random thing. just return what we got as a string. (list (string pathname))) (t ;; this is some other case; hopefully a string for the directory ;; such as "mhd", but who knows. You know someone should straighten ;; the Lisp Machine file mess out some day.... (loop for x in (fs:directory-list pathname) ; let user see error message; no files will be sent; reasonable for today. when (car x) collect (car x)))))) (defun string-for-kermit-infile (filename) (fs:merge-pathname-defaults filename kermit-default-pathname)) (defun string-for-kermit-outfile (filename) (fs:merge-pathname-defaults filename kermit-default-pathname)) (defun open-file-in-or-not (filename) (open filename ':in)) (defun open-file-out-or-not (filename) (open filename ':out)) (defvar *maxnamelength* 25) (defvar *maxtypelength* 25) ;;; @@@ string-for-kermit (defun string-for-kermit (filename &aux pathname dir name type version) "given a [lispm] pathname, GENERALLY returns /"name.type/"." (SETQ FILENAME (STRING FILENAME)) (prog () (setq pathname (fs:parse-pathname filename)) (selectq *filnamcnv* (:generic (setq dir nil name (maybe-handle-wildthing pathname ':name *filnamcnv*) type (maybe-handle-wildthing pathname ':type *filnamcnv*) version nil)) (:raw (return filename)) (otherwise (setq dir nil name (maybe-handle-wildthing pathname ':name *filnamcnv*) type (multiple-value-bind (thing winp) (fs:decode-canonical-type (send pathname ':canonical-type) *filnamcnv*) (if winp thing (maybe-handle-wildthing pathname ':type *filnamcnv*))) version nil))) (return (string-append (if dir (string-append dir name) name) "." (if version (string-append type version) type))))) (defprop :vms 9. *maxnamelength*) (defprop :vms 3. *maxtypelength*) (defun (:vms ok-filename-char) (x) (or (<= #/a x #/z) (<= #/A x #/Z) (<= #/0 x #/9) (= #/* x))) (defun maybe-handle-wildthing (pathname element system) (let ((s (cdr (assq element '((:name . *maxnamelength*) (:type . *maxtypelength*)))))) (let ((max-length (or (get system s) (symeval s)))) (let ((e (send pathname element))) (if (eq e ':wild) (setq e "*")) (if (eq e ':unspecific) (setq e "")) (if (get system 'ok-filename-char) (setq e (with-output-to-string (y) (do ((j 0 (1+ j))) ((= j (string-length e))) (if (funcall (get system 'ok-filename-char) (aref e j)) (send y ':tyo (aref e j))))))) (substring e 0 (min max-length (string-length e)))))))