;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-

;;; This code is in the public domain.

;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain.  Sbcl port by Rudi
;;; Schlatte.

(in-package "SB-SIMPLE-STREAMS")

;;;
;;; HELPER FUNCTIONS
;;;

;; All known stream flags.  Note that the position in the constant
;; list is significant (cf. %flags below).
(sb-int:defconstant-eqx +flag-bits+
                        '(:simple       ; instance is valid
                          :input :output ; direction
                          :dual :string	; type of stream
                          :eof          ; latched EOF
                          :dirty        ; output buffer needs write
                          :interactive) ; interactive stream
                        #'equal)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun %flags (flags)
    (loop for flag in flags
	  as pos = (position flag +flag-bits+)
	when (eq flag :gray) do
	  (error "Gray streams not supported.")
	if pos
	  sum (ash 1 pos) into bits
	else
	  collect flag into unused
      finally (when unused
		(warn "Invalid stream instance flag~P: ~{~S~^, ~}"
		      (length unused) unused))
	      (return bits))))

;;; Setup an environment where sm, funcall-stm-handler and
;;; funcall-stm-handler-2 are valid and efficient for a stream of type
;;; class-name or for the stream argument (in which case the
;;; class-name argument is ignored).  In nested with-stream-class
;;; forms, the inner with-stream-class form must specify a stream
;;; argument if the outer one specifies one, or the wrong object will
;;; be accessed.
(defmacro with-stream-class ((class-name &optional stream) &body body)
  (if stream
      (let ((stm (gensym "STREAM"))
	    (slt (gensym)))
	`(let* ((,stm ,stream)
		(,slt (sb-pcl::std-instance-slots ,stm)))
	   (declare (type ,class-name ,stm) (ignorable ,slt))
	   (macrolet ((sm (slot-name stream)
			(declare (ignore stream))
			(let ((slot-access (gethash slot-name
						    *slot-access-functions*)))
			  (cond ((sb-int:fixnump (cdr slot-access))
                                 ;; Get value in nth slot
				 `(the ,(car slot-access)
				    (sb-pcl::clos-slots-ref ,',slt
                                                            ,(cdr slot-access))))
				(slot-access
                                 ;; Call memorized function
				 `(the ,(car slot-access) (,(cdr slot-access)
							    ,',stm)))
				(t
                                 ;; Use slot-value
                                 `(slot-value ,',stm ',slot-name)))))
		      (add-stream-instance-flags (stream &rest flags)
			(declare (ignore stream))
			`(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
							  ,(%flags flags))))
		      (remove-stream-instance-flags (stream &rest flags)
			(declare (ignore stream))
			`(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
							    ,(%flags flags))))
		      (any-stream-instance-flags (stream &rest flags)
			(declare (ignore stream))
			`(not (zerop (logand (sm %flags ,',stm)
					     ,(%flags flags))))))
	     ,@body)))
      `(macrolet ((sm (slot-name stream)
		    (let ((slot-access (gethash slot-name
						*slot-access-functions*)))
		      (cond ((sb-int:fixnump (cdr slot-access))
			     `(the ,(car slot-access)
				(sb-pcl::clos-slots-ref
				 (sb-pcl::std-instance-slots ,stream)
				 ,(cdr slot-access))))
			    (slot-access
			     `(the ,(car slot-access) (,(cdr slot-access)
							,stream)))
			    (t `(slot-value ,stream ',slot-name))))))
	 ,@body)))

(defmacro sm (slot-name stream)
  (let ((slot-access (gethash slot-name *slot-access-functions*)))
    (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
    (cond ((sb-int:fixnump (cdr slot-access))
	   `(the ,(car slot-access) (sb-pcl::clos-slots-ref
				     (sb-pcl::std-instance-slots ,stream)
				     ,(cdr slot-access))))
	  (slot-access
	   `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
	  (t `(slot-value ,stream ',slot-name)))))

(defmacro funcall-stm-handler (slot-name stream &rest args)
  (let ((s (gensym)))
    `(let ((,s ,stream))
       (funcall (sm ,slot-name ,s) ,s ,@args))))

(defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
  (let ((s (gensym)))
    `(let ((,s ,stream))
       (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))

(defmacro add-stream-instance-flags (stream &rest flags)
  "Set the given flag bits in STREAM."
  (let ((s (gensym "STREAM")))
    `(let ((,s ,stream))
       (with-stream-class (simple-stream ,s)
	 (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))

(defmacro remove-stream-instance-flags (stream &rest flags)
  "Clear the given flag bits in STREAM."
  (let ((s (gensym "STREAM")))
    `(let ((,s ,stream))
       (with-stream-class (simple-stream ,s)
	 (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))

(defmacro any-stream-instance-flags (stream &rest flags)
  "Determine whether any one of the FLAGS is set in STREAM."
  (let ((s (gensym "STREAM")))
    `(let ((,s ,stream))
       (with-stream-class (simple-stream ,s)
	 (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))


(declaim (inline buffer-sap bref (setf bref) buffer-copy))

(defun buffer-sap (thing &optional offset)
  (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
	   (optimize (speed 3) (space 2) (debug 0) (safety 0)
		     ;; Suppress the note about having to box up the return:
		     (sb-ext:inhibit-warnings 3)))
  (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
    (if offset (sb-sys:sap+ sap offset) sap)))

(defun bref (buffer index)
  (declare (type simple-stream-buffer buffer)
	   (type (integer 0 #.most-positive-fixnum) index))
  (sb-sys:sap-ref-8 (buffer-sap buffer) index))

(defun (setf bref) (octet buffer index)
  (declare (type (unsigned-byte 8) octet)
	   (type simple-stream-buffer buffer)
	   (type (integer 0 #.most-positive-fixnum) index))
  (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))

(defun buffer-copy (src soff dst doff length)
  (declare (type simple-stream-buffer src dst)
	   (type fixnum soff doff length))
  (sb-sys:without-gcing ;; is this necessary??
   (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
                               (buffer-sap dst) (* doff 8)
                               (* length 8))))

(defun allocate-buffer (size)
  (if (= size sb-impl::bytes-per-buffer)
      (sb-impl::next-available-buffer)
      (make-array size :element-type '(unsigned-byte 8))))

(defun free-buffer (buffer)
  (when (not (vectorp buffer))
    (push buffer sb-impl::*available-buffers*))
  t)

(defun %fd-open (pathname direction if-exists if-exists-given
			  if-does-not-exist if-does-not-exist-given)
  (declare (type pathname pathname)
	   (type (member :input :output :io :probe) direction)
	   (type (member :error :new-version :rename :rename-and-delete
			 :overwrite :append :supersede nil) if-exists)
	   (type (member :error :create nil) if-does-not-exist))
  (multiple-value-bind (input output mask)
      (ecase direction
	(:input (values t nil sb-unix:o_rdonly))
	(:output (values nil t sb-unix:o_wronly))
	(:io (values t t sb-unix:o_rdwr))
	(:probe (values t nil sb-unix:o_rdonly)))
    (declare (type sb-int:index mask))
    (let ((name (cond ((sb-int:unix-namestring pathname input))
		      ((and input (eq if-does-not-exist :create))
		       (sb-int:unix-namestring pathname nil)))))
      ;; Process if-exists argument if we are doing any output.
      (cond (output
	     (unless if-exists-given
	       (setf if-exists
		     (if (eq (pathname-version pathname) :newest)
			 :new-version
			 :error)))
	     (case if-exists
	       ((:error nil)
		(setf mask (logior mask sb-unix:o_excl)))
	       ((:rename :rename-and-delete)
		(setf mask (logior mask sb-unix:o_creat)))
	       ((:new-version :supersede)
		(setf mask (logior mask sb-unix:o_trunc)))
	       (:append
		(setf mask (logior mask sb-unix:o_append)))))
	    (t
	     (setf if-exists nil)))	; :ignore-this-arg
      (unless if-does-not-exist-given
	(setf if-does-not-exist
	      (cond ((eq direction :input) :error)
		    ((and output
			  (member if-exists '(:overwrite :append)))
		     :error)
		    ((eq direction :probe)
		     nil)
		    (t
		     :create))))
      (if (eq if-does-not-exist :create)
	  (setf mask (logior mask sb-unix:o_creat)))

      (let ((original (if (member if-exists
                                  '(:rename :rename-and-delete))
                          (sb-impl::pick-backup-name name)
                          nil))
	    (delete-original (eq if-exists :rename-and-delete))
	    (mode #o666))
	(when original
	  ;; We are doing a :rename or :rename-and-delete.
	  ;; Determine if the file already exists, make sure the original
	  ;; file is not a directory and keep the mode
	  (let ((exists
		 (and name
		      (multiple-value-bind
			    (okay err/dev inode orig-mode)
			  (sb-unix:unix-stat name)
			(declare (ignore inode)
				 (type (or sb-int:index null) orig-mode))
			(cond
			  (okay
			   (when (and output (= (logand orig-mode #o170000)
						#o40000))
			     (error 'sb-int:simple-file-error
				 :pathname pathname
				 :format-control
				 "Cannot open ~S for output: Is a directory."
				 :format-arguments (list name)))
			   (setf mode (logand orig-mode #o777))
			   t)
			  ((eql err/dev sb-unix:enoent)
			   nil)
			  (t
			   (error 'sb-int:simple-file-error
				  :pathname pathname
				  :format-control "Cannot find ~S: ~A"
				  :format-arguments
				    (list name
				      (sb-int:strerror err/dev)))))))))
	    (unless (and exists
			 (rename-file name original))
	      (setf original nil)
	      (setf delete-original nil)
	      ;; In order to use SUPERSEDE instead, we have
	      ;; to make sure unix:o_creat corresponds to
	      ;; if-does-not-exist.  unix:o_creat was set
	      ;; before because of if-exists being :rename.
	      (unless (eq if-does-not-exist :create)
		(setf mask (logior (logandc2 mask sb-unix:o_creat)
				   sb-unix:o_trunc)))
	      (setf if-exists :supersede))))
	
	;; Okay, now we can try the actual open.
	(loop
	  (multiple-value-bind (fd errno)
	      (if name
		  (sb-unix:unix-open name mask mode)
		  (values nil sb-unix:enoent))
	    (cond ((sb-int:fixnump fd)
		   (return (values fd name original delete-original)))
		  ((eql errno sb-unix:enoent)
		   (case if-does-not-exist
		     (:error
		       (cerror "Return NIL."
			       'sb-int:simple-file-error
			       :pathname pathname
			       :format-control "Error opening ~S, ~A."
			       :format-arguments
			           (list pathname
				         (sb-int:strerror errno))))
		     (:create
                      (cerror "Return NIL."
			       'sb-int:simple-file-error
			       :pathname pathname
			       :format-control
				   "Error creating ~S, path does not exist."
			       :format-arguments (list pathname))))
		   (return nil))
		  ((eql errno sb-unix:eexist)
		   (unless (eq nil if-exists)
		     (cerror "Return NIL."
			     'sb-int:simple-file-error
			     :pathname pathname
			     :format-control "Error opening ~S, ~A."
			     :format-arguments
			         (list pathname
				       (sb-int:strerror errno))))
		   (return nil))
                  #+nil ; FIXME: reinstate this; error reporting is nice.
		  ((eql errno sb-unix:eacces)
		   (cerror "Try again."
			   'sb-int:simple-file-error
			   :pathname pathname
			   :format-control "Error opening ~S, ~A."
			   :format-arguments
			       (list pathname
				     (sb-int:strerror errno))))
		  (t
		   (cerror "Return NIL."
			   'sb-int:simple-file-error
			   :pathname pathname
			   :format-control "Error opening ~S, ~A."
			   :format-arguments
			       (list pathname
				     (sb-int:strerror errno)))
		   (return nil)))))))))

(defun open-fd-stream (pathname &key (direction :input)
				(element-type 'base-char)
				(if-exists nil if-exists-given)
				(if-does-not-exist nil if-does-not-exist-given)
				(external-format :default))
  (declare (type (or pathname string stream) pathname)
	   (type (member :input :output :io :probe) direction)
	   (type (member :error :new-version :rename :rename-and-delete
			 :overwrite :append :supersede nil) if-exists)
	   (type (member :error :create nil) if-does-not-exist)
	   (ignore external-format))
  (setq pathname (pathname pathname))
  (multiple-value-bind (fd namestring original delete-original)
      (%fd-open pathname direction if-exists if-exists-given
		if-does-not-exist if-does-not-exist-given)
    (when fd
      (case direction
	((:input :output :io)
	 (sb-sys:make-fd-stream fd
                                :input (member direction '(:input :io))
                                :output (member direction '(:output :io))
                                :element-type element-type
                                :file namestring
                                :original original
                                :delete-original delete-original
                                :pathname pathname
                                :input-buffer-p t
                                :auto-close t))
	(:probe
	 (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
                                                 :pathname pathname
                                                 :element-type element-type)))
	   (close stream)
	   stream))))))


;; Make PATHNAME and NAMESTRING work
(defun cl::file-name (stream &optional new-name)
  (typecase stream
    (file-simple-stream
     (with-stream-class (file-simple-stream stream)
       (cond (new-name
	      (setf (sm pathname stream) new-name)
	      (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
	      t)
	     (t
	      (sm pathname stream)))))
    (sb-sys::file-stream
     (cond (new-name
	    (setf (sb-impl::fd-stream-pathname stream) new-name)
	    (setf (sb-impl::fd-stream-file stream)
		  (sb-int:unix-namestring new-name nil))
	    t)
	   (t
	    (sb-impl::fd-stream-pathname stream))))))

;; Experimental "filespec" stuff

;; sat: Hooks to parse URIs etc apparently go here

(defstruct (filespec-parser
	     (:constructor make-filespec-parser (name priority function)))
  name
  priority
  function)

(defvar *filespec-parsers* ())

(defun add-filespec (name priority function)
  (let ((filespec (make-filespec-parser name priority function)))
    (setf *filespec-parsers*
	  (stable-sort (cons filespec (delete name *filespec-parsers*
					      :key #'filespec-parser-name))
		       #'>
		       :key #'filespec-parser-priority)))
  t)

(defmacro define-filespec (name lambda-list &body body)
  (let ((truename (if (consp name) (first name) name))
	(priority (if (consp name) (second name) 0)))
    `(add-filespec ',truename ,priority (lambda ,lambda-list
					  (block ,truename
					    ,@body)))))

(defun parse-filespec (string &optional (errorp t))
  (dolist (i *filespec-parsers* (when errorp
				  (error "~S not recognised." string)))
    (let ((result (ignore-errors
		    (funcall (filespec-parser-function i) string))))
      (when result (return result)))))

(define-filespec pathname (string)
  (pathname string))