p4bee.lisp

;; Lispworks 6.00 required and p4 executable
;; Tested only under Vista 64 bit with Lispworks Professional 32-bit
;;
(defpackage "P4BEE" (:use "CL"))
(in-package "P4BEE")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((dir (or *compile-file-truename* *load-truename* *default-pathname-defaults*)))
    (format t "*compile-file-truename* = ~A~&" *compile-file-truename*)
    (format t "*load-truename* = ~A~&" *load-truename*)
    (format t "*default-pathname-defaults* = ~A~&" *default-pathname-defaults*)
    (load (merge-pathnames "asdf/asdf" dir))
    (mapcar (lambda (name)
              (load (merge-pathnames name dir)))
            '(;;"asdf/asdf"
              "trivial-gray-streams-2008-11-02/trivial-gray-streams.asd"
              "flexi-streams-1.0.7/flexi-streams.asd"
              "cl-ppcre-2.0.3/cl-ppcre.asd"))
    (funcall (find-symbol "LOAD-SYSTEM" "ASDF") "cl-ppcre")))

;;(load (merge-pathnames "asdf/asdf")

(setf (lw:environment-variable "P4HOST") "malkiaBook.local")
(setf (lw:environment-variable "P4PORT") "public.perforce.com:1666")

;;; Silly things done with LispWorks CAPI and Perforce

;;; sys:open-pipe is Lispworks specific

(defmacro with-pipe ((stream command &rest rest) &body body)
  "Opens a pipe, by executing the 'command'. Captures the output in 'stream'. Expands the 'body'. At the end closes the pipe."
  `(let ((,stream (sys:open-pipe ,command ,@rest)))
     (prog1 ,@body
       (close ,stream))))

(defmacro for-each-line ((stream line) what &body body)
  "Wrapper around 'for'. Iterates through each line while there is line and does 'what' to the 'body'"
  `(loop for ,line = (read-line ,stream nil nil)
         while ,line
         ,what ,@body))

(defun tabulate-line (line &key keep-function)
  "Splits a sequence. If (keep-function item index)"
  (let ((list (lw:split-sequence " " line :coalesce-separators t)))
    (format t "~S~&~S~&~%" list keep-function)
    (if keep-function
        (loop for index from 0
              for item in list
              do (print index)
              do (print item)
              when t;;(apply keep-function index item)
              collect item)
      list)))
        
(defun tabulate-list (list &rest rest)
  "Splits a list of sequences"
  (loop for line in list
        collect (apply 'tabulate-line (cons line rest))))

(defun split-change (change)
  (let* ((split2 (lw:split-sequence "'" change :coalesce-separators t))
         (split1 (lw:split-sequence " " (first split2) :coalesce-separators t))
         (split (append split1 (rest split2)))
         (result (list (nth 1 split) (nth 3 split) (nth 4 split)
                       (nth 6 split) (nth 7 split))))
    result))

(defun split-changes (changes)
  (loop for change in changes
        collect (split-change change)))

;;; Perforce specific macros & functions

(defmacro with-p4 ((stream command &optional (arguments "") &rest rest) &body body)
  `(with-pipe (,stream (format nil #+mac "/opt/local/bin/p4 ~A ~A" #-mac "p4 ~A ~A" ,command ,arguments) ,@rest)
     ,@body))

(defun parse-p4-info-line (line)
  (let ((p (position #\: line)))
    (cons (intern (string-upcase (substitute #\- #\Space (subseq line 0 p))) "KEYWORD")
          (string-trim " " (subseq line (1+ p))))))

(defun p4-info ()
  (with-p4 (s "info")
    (for-each-line (s line) collect
      (parse-p4-info-line line))))

(defun p4 (command &optional (arguments ""))
  (with-p4 (s command arguments)
    (for-each-line (s line)
        collect line)))

;;; Some default information

(defvar *info* (p4-info))
(defvar *user* (cdr (assoc :USER-NAME *info*)))
(defvar *client* (cdr (assoc :CLIENT-NAME *info*)))
(defvar *root* (cdr (assoc :CLIENT-ROOT *info*)))
(defvar *host* (cdr (assoc :CLIENT-HOST *info*)))
(defvar *version* (cdr (assoc :SERVER-VERSION *info*)))

;;; Some CAPI stuff

;;; Simple "p4 monitor show" tabular display

(capi:define-interface monitor-interface ()
  (auto-refresh-timer)
  (:panes
   (panel capi:multi-column-list-panel
          :columns '((:title "ID")
                     (:title "A")
                     (:title "User")
                     (:title "Time")
                     (:title "Operation"))
          :title "p4 monitor show")
   (refresh capi:push-button
            :callback-type :interface
            :callback 'refresh-monitor
            :text "Refresh"))
  (:default-initargs
   :visible-min-width 320
   :visible-min-height 200))

(defmethod refresh-monitor ((monitor-interface monitor-interface))
  (with-slots (panel) monitor-interface
    (setf (capi:collection-items panel)
          (tabulate-list (p4 "monitor show")))))  

(defmethod initialize-instance :after ((monitor-interface monitor-interface) &rest rest)
  (refresh-monitor monitor-interface)
  (with-slots (auto-refresh-timer) monitor-interface
    (mp:schedule-timer-relative
     (setf auto-refresh-timer
           (mp:make-timer 'capi:execute-with-interface-if-alive
                          monitor-interface 'refresh-monitor monitor-interface))
     1 5)))
  
(defun show-monitor ()
  (capi:display (make-instance 'monitor-interface)))

;;; 

(capi:define-interface submitted-changelists-interface ()
  ()
  (:panes
   (panel capi:multi-column-list-panel
          :columns '((:title "Changelist")
                     (:title "Date")
                     (:title "Time")
                     (:title "User")
                     (:title "Description"))
          :title "p4 monitor show")
   (refresh capi:push-button
            :callback-type :interface
            :callback 'refresh-submitted-changelists
            :text "Refresh"))
  (:default-initargs
   :visible-min-width 640
   :visible-min-height 480))

(defmethod refresh-submitted-changelists ((submitted-changelists-interface submitted-changelists-interface))
  (with-slots (panel) submitted-changelists-interface
    (setf (capi:collection-items panel)
          (split-changes (p4 "changes -m 300 -t -s submitted")))))

(defmethod initialize-instance :after ((submitted-changelists-interface submitted-changelists-interface) &rest rest)
  (refresh-submitted-changelists submitted-changelists-interface))

(defun show-submitted-changelists ()
  (capi:display (make-instance 'submitted-changelists-interface)))

;;;

(defun test1 (num &key k)
  (format t "~A ~A" num k))

(defun test2 (num &rest rest)
  (apply 'test1 num rest))

(capi:define-interface combined-test-interface ()
  ()
  (:panes
   (monitor monitor-interface)
   (changes submitted-changelists-interface))
  (:default-initargs
   :visible-min-width 1024
   :visible-min-height 768))

(defun combined-test ()
  (capi:display (make-instance 'combined-test-interface)))


(defparameter *p4-changes-1*
  '("Change <number1> on <date1> <time1> <user1> {*status*}<nl><nl><tab><description><nl><tab>"))

(defparameter *text*
  "Change 5677 on 2006/09/26 07:27:28 by tony_smith@tony_smith-barney-public

	Rework P4Perl build script to support 2006.1 API. There were
	some sweeping changes in the 2006.1 API which did away with the
	old const_char definition. Unfortunately, since P4Perl has to
	build with older APIs, I can't quite do the same. This change
	t

Change 5676 on 2006/09/25 17:27:25 by richard_geiger@richard_geiger-ip-alison2

	Add $CONVUSER to set owner for label and depot specs create dby the
	conversion.
")

(defparameter *regex*
;;  "^Change [0..9]* on [0-9/]+ [0-9:]+ by [a-zA-Z@-_.]+"
  "\\(Change\\) \\([0-9]+\\)"
)



(defun regtest ()
  (loop with pattern = (lw:precompile-regexp *regex*)
        with pos = 0 
        with len = 0 
        while pos 
        do (multiple-value-setq (pos len)
               (lw:find-regexp-in-string pattern *text*
                                      :start (+ pos len))) 
        when pos do (format t "~&Match at pos ~D len ~D~%" 
                            pos len)))