(in-package "P4COM")

;; This file, automatically loaded by load.lisp, establishes a
;; connection to the p4 server. It defines an abstract function p4-run
;; for accessing the connection, and a number of concrete functions
;; (p4-edit, etc.) in terms of p4-run.

(fli:define-foreign-function (register-p4com-dll "DllRegisterServer")
    ()
    :module :p4com
    :result-type (:void)
    :calling-convention :cdecl)

(defparameter *p4com-library-path* (current-pathname "p4com" "dll"))

(defun register-thread-for-p4com ()
  (unless (getf (mp:process-plist mp:*current-process*)
		'thread-registered-for-p4com)
    (fli:register-module :p4com
			 :real-name (namestring *p4com-library-path*))
    (register-p4com-dll)
    (com:co-initialize)
    (setf (getf (mp:process-plist mp:*current-process*)
		'thread-registered-for-p4com)
	  t)))

(defun p4-configs (here)
  (when-let (p4-config (or (environment-variable "P4CONFIG")
                           (win32:registry-value "Software\\perforce\\environment" "P4CONFIG"
                                                 :expected-type :string :errorp nil :root :local-machine)
                           (win32:registry-value "Software\\perforce\\environment" "P4CONFIG"
                                                 :expected-type :string :errorp nil)))
    (let ((directory (pathname-directory here)))
      (loop (let ((config-file (make-pathname :directory directory
                                              :name (pathname-name p4-config)
                                              :type (pathname-type p4-config)
                                              :defaults here)))
              (when (probe-file config-file)
                (return
                 (with-open-file (in config-file)
                   (loop for line = (read-line in nil)
                         while line
                         for equals = (position #\= line)
                         collect (intern (subseq line 0 equals) :keyword)
                         collect (subseq line (1+ equals)))))))
            (unless (setf directory (butlast directory))
              (return))))))

(defvar *p4* (make-hash-table :test 'equalp))

(defun p4-connection ()
  (register-thread-for-p4com)
  (let ((current-location (truename (pathname-location (or (editor:buffer-pathname (editor:current-buffer))
                                                           (sys:current-directory))))))
    (or (gethash current-location *p4*)
        (setf (gethash current-location *p4*)
              (let* ((unknown (com:create-instance "P4com.p4"))
                     (p4 (com:query-interface unknown 'ip-4))
                     (p4-configs (p4-configs current-location)))
                (com:release unknown)
                (loop for (key value) on p4-configs by 'cddr do
                      ;; Sigh
                      (case key
                        ((:p4port) (com:call-com-interface (p4 ip-4 put-port) value))
                        ((:p4user) (com:call-com-interface (p4 ip-4 put-user) value))
                        ((:p4client) (com:call-com-interface (p4 ip-4 put-client) value))))
                (com:call-com-interface (p4 ip-4 parse-forms))
                (com:call-com-interface (p4 ip-4 connect))
                p4)))))

(defun p4-run (format-string &rest format-arguments)
  (com:call-dispatch-method ((p4-connection) ip-4 run)
			    (format nil "~?" format-string
                                    format-arguments)))

(defun p4-info ()
  (p4-run "info"))

(defun p4-edit (file)
  (p4-run "edit \"~a\""
          (namestring (truename file))))

(defun p4-opened (all-p)
  (let ((opened (p4-run (if all-p
                            "opened"
                          "opened -cdefault"))))
    (format nil "~{~a~^~%~}"
            (loop for i from 0 by 8 while (< i (length opened))
                  collect 
                  (let* ((depot-line (svref opened i))
                         (space (position #\Space depot-line)))
                    (subseq depot-line (1+ space)))))))

(defun local-file (p4-file)
  (third (p4-run (format nil "where ~a" p4-file))))

(defun p4-grab-jobspec ()
  (p4-run "jobspec -o")
  (let ((p4 (p4-connection)))
    (values (com:call-dispatch-get-property (p4 ip-4 array-var) "Fields")
            (com:call-dispatch-get-property (p4 ip-4 array-var) "Values")
            (com:call-dispatch-get-property (p4 ip-4 array-var) "Presets"))))

;;;;;;;;;;;;;;;;;

;; COPYRIGHT AND LICENCE
;;
;; This file is copyright (c) 2003, Nick Levine.  All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; 1.  Redistributions of source code must retain the above copyright
;;     notice, this list of conditions and the following disclaimer.
;;
;; 2.  Redistributions in binary form must reproduce the above copyright
;;     notice, this list of conditions and the following disclaimer in
;;     the documentation and/or other materials provided with the
;;     distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
;; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
;; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.

;; $Id: //info.ravenbrook.com/user/ndl/lisp/p4com/p4.lisp#6 $