;;; -*- PACKAGE:KERMIT;BASE:8;IBASE:8;MODE:LISP-*-



;******************************************************************************
; Copyright (c) 1984, 1985 by Lisp Machine Inc.
; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
; Permission to copy all or part of this material is granted, provided
; that the copies are not made or distributed for resale, and the 
; copyright notices and reference to the source file and the software
; distribution version appear, and that notice is given that copying is
; by permission of Lisp Machine Inc.  LMI reserves for itself the 
; sole commercial right to use any part of this KERMIT/H19-Emulator
; not covered by any Columbia University copyright.  Inquiries concerning
; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
;
; Version Information:
;      LMKERMIT 1.0     --      Original LMI code, plus edit ;1; for 3600 port
;
; Authorship Information:
;      Mark David (LMI)           Original version, using KERMIT.C as a guide
;      George Carrette (LMI)      Various enhancements
;      Mark Ahlstrom (Honeywell)  Port to 3600 (edits marked with ";1;" comments)
;
; Author Addresses:
;      George Carrette     ARPANET: GJC at MIT-MC
;
;      Mark Ahlstrom       ARPANET: Ahlstrom at HI-Multics
;                          PHONE:   (612) 887-4006
;                          USMAIL:  Honeywell MN09-1400
;                                   Computer Sciences Center
;                                   10701 Lyndale Avenue South
;                                   Bloomington, MN  55420
;******************************************************************************


(declare (special interaction-pane debug-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 *filelist* (cdr *filelist*))
                          (setq *filnam* (car *filelist*)))
  (cond ((#-3600 consp #+3600 listp *filnam*)	;1; can probably just make this listp for all...
           (setq *as-filnam* (cadr *filnam*) *filnam* (car *filnam*))))
  *FILELIST*)





;1; For 3600, I changed this around to defvar it earlier in the calls file.
;1; The .system file has also been changed to ensure that calls will be loaded
;1; before this file.
#-3600 (defconst kermit-default-pathname :unbound)
#+3600 (declare (special kermit-default-pathname))


(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 #-3600 (multiple-value-bind (thing winp)	;1; no fs:decode... on 3600
				     (fs:decode-canonical-type (send pathname ':canonical-type) *filnamcnv*)
				   (if winp
				       thing
				       (maybe-handle-wildthing pathname ':type *filnamcnv*)))
		          #+3600 (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)))))))