;;;  -*- Mode:Common-Lisp; Package:ZWEI; Base:8 -*-

;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.
;;;
;;;  The commands in this file are not supported by TI.  They do work,
;;;  at least sometimes.  We are likely to release and support these commands
;;;  in the future.

; Copyright (C) 1980, Massachusetts Institute of Technology
; Copyright (C) 1984, Texas Instruments Incorporated. All rights reserved.

;;;; BDIRED Lines


(DEFSUBST BDIRED-CURRENT-LINE (STREAM)
  (BP-LINE (SEND STREAM :READ-BP))) 

(DEFSUBST BDIRED-PREVIOUS-LINE (STREAM)
  (LINE-PREVIOUS (BDIRED-CURRENT-LINE STREAM))) 

(DEFSUBST BDIRED-NEXT-LINE (STREAM)
  (LINE-NEXT (BDIRED-CURRENT-LINE STREAM))) 

(DEFSUBST PUT-LINE (LINE ITEM KEY)
  (SETF (GETF (LINE-PLIST LINE) KEY) ITEM)) 

(DEFSUBST GET-LINE (LINE KEY)
  (GETF (LINE-PLIST LINE) KEY)) 

(DEFUN BDIRED-DELETE-LINE (FIRST-LINE &OPTIONAL LAST-LINE)
  (IF (NULL LAST-LINE)
      (SETQ LAST-LINE FIRST-LINE))
  (WITH-READ-ONLY-SUPPRESSED (*INTERVAL*)
    (DELETE-INTERVAL (BEG-LINE (CREATE-BP FIRST-LINE 0) 0)
		     (BEG-LINE (CREATE-BP LAST-LINE 0) 1)
		     T))) 

;;; Line CFILE.
(DEFUN BDIRED-LIST-CFILE (CFILE STREAM)
  (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* CFILE STREAM)
  (LET ((LINE (BDIRED-PREVIOUS-LINE STREAM)))
    (SETF (LINE-PLIST LINE) (CONS :PATHNAME CFILE))
    LINE)) 

(DEFSUBST BDIRED-LINE-CFILE (LINE)
  (CDR (GETL (LOCF (LINE-PLIST LINE)) '(:PATHNAME)))) 

;;;; BDIRED Buffers

;(DEFSUBST BDIRED-ALTERNATE-PATHNAME (BUFFER)
;  (FOURTH (BUFFER-FILE-ID BUFFER)))

(DEFSUBST BDIRED-ALTERNATE-PATHNAME (BUFFER)
  (GETF (NODE-PROPERTY-LIST BUFFER) :ALTERNATE-PATHNAME)) 

(DEFSUBST UPDATE-BDIRED-BUFFER-PATHNAMES (BUFFER PATHNAME1 PATHNAME2)
  (SETF (BUFFER-PATHNAME BUFFER) PATHNAME1)
  (SETF (BDIRED-ALTERNATE-PATHNAME BUFFER) PATHNAME2)) 

(DEFUN FIND-OR-CREATE-BDIRED-BUFFER (PATHNAME1 PATHNAME2)
  (LET ((BUFFER (SEND SELF :FIND-SPECIAL-BUFFER :BDIRED T "BDired")))
    (IF (NULL BUFFER)
	(ERROR "Cannot find BDIRED buffer"))
    (UPDATE-BDIRED-BUFFER-PATHNAMES BUFFER PATHNAME1 PATHNAME2)
    BUFFER)) 

;;;; Pathname Stuff

(DEFUN BDIRED-READ-DIRECTORY-STRING (PROMPT PATHNAME)
  (LET ((*READING-PATHNAME-DEFAULTS* PATHNAME)
	(*READING-PATHNAME-SPECIAL-TYPE* (PATHNAME-TYPE PATHNAME))
	(*READING-PATHNAME-SPECIAL-VERSION* (PATHNAME-VERSION PATHNAME))
	(*READING-PATHNAME-DIRECTION* :READ))
    (MULTIPLE-VALUE-BIND (NIL NIL INTERVAL)
	(EDIT-IN-MINI-BUFFER *PATHNAME-READING-COMTAB* NIL NIL
			     (LIST (FORMAT NIL "~A (Default is ~A)" PROMPT PATHNAME)
				   '(:RIGHT-FLUSH " (Completion)")))
      (STRING-INTERVAL INTERVAL)))) 

(DEFUN BDIRED-READ-DIRECTORY-NAME (PROMPT PATHNAME)
  (LET ((INTERVAL (BDIRED-READ-DIRECTORY-STRING PROMPT PATHNAME)))
    (COND ((EQUAL INTERVAL "")
	   PATHNAME)
	  (T
	   (FS:MERGE-PATHNAME-DEFAULTS INTERVAL PATHNAME NIL NIL))))) 

;;;; Top Level

(DEFVAR *BDIRED-PATHNAME1-NAME* :UNBOUND "Pathname of active BDIRED buffer") 

(DEFVAR *BDIRED-PATHNAME2-NAME* :UNBOUND "Alternate pathname of active BDIRED buffer") 

(DEFMAJOR COM-BDIRED-MODE BDIRED-MODE "BDired" "Setup for editing directory differences" ()
  (PROGN					;Due to ZWEI inversion lossage.
    (IF (TYPEP *INTERVAL* 'FILE-BUFFER)
	(LET ((PATHNAME1 (BUFFER-PATHNAME *INTERVAL*))
	      (PATHNAME2 (BDIRED-ALTERNATE-PATHNAME *INTERVAL*)))
	  (IF (NOT (NULL PATHNAME1))
	      (SETQ *BDIRED-PATHNAME1-NAME* (STRING PATHNAME1)))
	  (IF (NOT (NULL PATHNAME2))
	      (SETQ *BDIRED-PATHNAME2-NAME* (STRING PATHNAME2))))))
  (SET-COMTAB *MODE-COMTAB*
	      '(#\SPACE COM-DOWN-REAL-LINE
		#\= COM-DIRED-SRCCOM
		#\? COM-BDIRED-DOCUMENTATION
		#\HELP COM-BDIRED-DOCUMENTATION
		#\C COM-DIRED-COPY
		#\c (0 #\C)
		#\I COM-BDIRED-RESOLVE-INCONSISTENCY
		#\i (0 #\I)
		#\Q COM-BDIRED-EXIT
		#\q (0 #\Q)
		#\R COM-DIRED-RENAME
		#\r (0 #\R)
		#\T COM-BDIRED-TRANSFER
		#\t (0 #\T)
		#\U COM-BDIRED-UNDELETE
		#\u (0 #\U)
		#\V COM-DIRED-VIEW-FILE
		#\v (0 #\V)
		#\RUBOUT COM-DIRED-REVERSE-UNDELETE
		#\ABORT COM-BDIRED-ABORT
		#\END COM-BDIRED-EXIT)
	      '())
  (SETQ *MODE-LINE-LIST*
	(APPEND *MODE-LINE-LIST*
		'("  " *BDIRED-PATHNAME1-NAME*
		  "  " *BDIRED-PATHNAME2-NAME*
		  "  (Q to exit)")))) 

(DEFUN (:PROPERTY BDIRED-MODE PATHNAME-DEFAULTING-FUNCTION) (IGNORE BUFFER)
  (AND (EQ BUFFER *INTERVAL*)
       (DONT-OPTIMIZE
	 (DIRED-LINE-PATHNAME (BP-LINE (POINT)))))) 

(DEFCOM COM-BDIRED "Edit the differences between two directories.
This command is not currently supported by TI, but it works in most situations." ()
  (KILL-NEW-BUFFER-ON-ABORT (*INTERVAL*)
    (LET* ((DEFAULT (SEND (DEFAULT-PATHNAME) :NEW-PATHNAME
			  :NAME NIL
			  :TYPE NIL
			  :VERSION NIL))
	   (PATHNAME1 (BDIRED-READ-DIRECTORY-NAME "Balance directory" DEFAULT)))
      (BDIRECTORY-EDIT PATHNAME1
		       (BDIRED-READ-DIRECTORY-NAME
			 (FORMAT NIL "Balance directory ~A with directory" PATHNAME1)
			 PATHNAME1))))) 


(DEFUN BDIRECTORY-EDIT (PATHNAME1 PATHNAME2)
  "Enter the balance directories editor on directories PATHNAME1 and PATHNAME2.
In ZMACS, this creates a BDIRED buffer and reads the differences into it,
making it the current buffer."
  (LET ((*INTERVAL* (FIND-OR-CREATE-BDIRED-BUFFER PATHNAME1 PATHNAME2)))
    (MAKE-BUFFER-READ-ONLY *INTERVAL*)
    (COM-BDIRED-MODE)
    (BDIRED-INITIALIZE-BUFFER *INTERVAL* PATHNAME1 PATHNAME2)
    DIS-TEXT)) 

;;;; BDIRED Buffer Initialization

(DEFPROP BDIRED-MODE BDIRECTORY-EDIT-REVERT MAJOR-MODE-REVERT-FUNCTION) 

(DEFUN BDIRECTORY-EDIT-REVERT (BUFFER PATHNAME &OPTIONAL IGNORE SELECT-FLAG)
  "Revert a BDIRED buffer."
  (BDIRED-INITIALIZE-BUFFER BUFFER
			    PATHNAME
			    (BDIRED-ALTERNATE-PATHNAME BUFFER)
			    SELECT-FLAG)) 


(DEFUN BDIRED-INITIALIZE-BUFFER (BUFFER PATHNAME1 PATHNAME2 &OPTIONAL SELECT-FLAG)
  "Initialize a BDIRED buffer."
  (WITH-READ-ONLY-SUPPRESSED (BUFFER)
    (LET ((*BATCH-UNDO-SAVE* T)
	  (SELECTED-P (EQ BUFFER *INTERVAL*))
	  (*INTERVAL* BUFFER)
	  (DIR1 (FS::CREATE-CDIRECTORY PATHNAME1 '() T))
	  (DIR2 (FS::CREATE-CDIRECTORY PATHNAME2 '() T)))
      ;; What directories did we ultimately read?  Maybe the user corrected an error.
      (SETQ PATHNAME1 (FS::CDIRECTORY-PATHNAME DIR1))
      (SETQ PATHNAME2 (FS::CDIRECTORY-PATHNAME DIR2))
      (UPDATE-BDIRED-BUFFER-PATHNAMES BUFFER PATHNAME1 PATHNAME2)
      (FS::COMPARE-CDIRECTORIES DIR1 DIR2)
      (DELETE-INTERVAL BUFFER)
      (DISCARD-UNDO-INFORMATION BUFFER)
      (IF SELECTED-P
	  (SETQ *BDIRED-PATHNAME1-NAME* (SEND PATHNAME1 :STRING-FOR-PRINTING)
		*BDIRED-PATHNAME2-NAME* (SEND PATHNAME2 :STRING-FOR-PRINTING)))
      (LET ((STREAM (INTERVAL-STREAM-INTO-BP (INTERVAL-FIRST-BP BUFFER))))
	(BDIRED-INSERT-DIRECTORY DIR1 STREAM DIR2)
	(WRITE-CHAR #\NEWLINE STREAM)
	(BDIRED-INSERT-DIRECTORY DIR2 STREAM DIR1))
      (LET ((FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP BUFFER))))
	(PUT-LINE FIRST-LINE DIR1 'CDIRECTORY1)
	(PUT-LINE FIRST-LINE DIR2 'CDIRECTORY2)))
    (BDIRED-MARK-INITIAL-TRANSFERS))
  (IF SELECT-FLAG
      (MAKE-BUFFER-CURRENT BUFFER))) 

(DEFUN BDIRED-INSERT-DIRECTORY (DIRECTORY STREAM ALTERNATE-DIRECTORY)
  (LET ((DIRLIST (FS::CDIRECTORY-LIST DIRECTORY))
	(PATHNAME (FS::CDIRECTORY-PATHNAME DIRECTORY)))
    (DOLIST (CFILE (CDR DIRLIST))
      (SETF (GET (FS::CFILE-PLIST CFILE) 'ALTERNATE-DIRECTORY) ALTERNATE-DIRECTORY))
    (SEND STREAM :STRING-OUT (SEND PATHNAME :STRING-FOR-PRINTING))
    (SEND STREAM :LINE-PUT :DIRECTORY PATHNAME)
    (SEND STREAM :TYO #\NEWLINE)
    (SEND *DIRECTORY-SINGLE-FILE-LISTER* (CAR DIRLIST) STREAM)
    (DIRED-INSERT-DIRECTORY DIRLIST STREAM 0))) 

;;;; Commands

(DEFCOM COM-BDIRED-EXIT "Exit from BDIRED, performing transfers that you have selected.
This command is not currently supported by TI, but it works in most situations." ()
  (IF (BDIRED-PROCESS-FILES)
      (SEND SELF :EXIT-SPECIAL-BUFFER T *INTERVAL*))
  DIS-BPS) 

(DEFCOM COM-BDIRED-ABORT "Exit BDIRED, not transferring any files.
This command is not currently supported by TI, but it works in most situations." ()
  (SEND SELF :EXIT-SPECIAL-BUFFER T *INTERVAL*)
  DIS-BPS) 

(DEFUN BDIRED-MAP-OVER-ALL-LINES (FUN)
  (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)) (LINE-NEXT LINE))
       (LAST-LINE (BP-LINE (INTERVAL-LAST-BP *INTERVAL*))))
      ((EQ LINE LAST-LINE))
    (FUNCALL FUN LINE))) 

(DEFUN BDIRED-MARK-INITIAL-TRANSFERS ()
  (BDIRED-MAP-OVER-ALL-LINES (FUNCTION BDIRED-MARK-INITIAL-TRANSFER))) 

(DEFUN BDIRED-MARK-INITIAL-TRANSFER (LINE)
  (COND ((NOT (NULL (FS::CFILE-TRANSFER-DESTINATIONS (BDIRED-LINE-CFILE LINE))))
	 (MUNG-LINE LINE)
	 (SETF (AREF LINE 0) #\T)))) 

(DEFUN BDIRED-MARK-TRANSFER (CFILE)
  (FS::MARK-CFILE-FOR-TRANSFER
    CFILE
    (GET (FS::CFILE-PLIST CFILE) 'ALTERNATE-DIRECTORY))) 

(DEFUN BDIRED-UNMARK-TRANSFER (CFILE)
  (IF (NOT (NULL (FS::CFILE-TRANSFER-DESTINATIONS CFILE)))
      (SETF (FS::CFILE-TRANSFER-DESTINATIONS CFILE) '()))) 

(DEFUN BDIRED-PROCESS-FILES ()
  (LET* ((*TERMINAL-IO* *TYPEIN-WINDOW*)
	 (FIRST-LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*)))
	 (DIR1 (GET-LINE FIRST-LINE 'CDIRECTORY1))
	 (DIR2 (GET-LINE FIRST-LINE 'CDIRECTORY2)))
    (FS::SETUP-CDIRECTORY-TRANSFER-MODE DIR1)
    (FS::SETUP-CDIRECTORY-TRANSFER-MODE DIR2)
    (FS::CDIRECTORY-TRANSFER DIR1)
    (FS::CDIRECTORY-TRANSFER DIR2))
  T) 

(DEFCOM COM-BDIRED-TRANSFER "Mark file(s) for transfer.
This command is not currently supported by TI, but it works in most situations." ()
  (DIRED-MAP-OVER-LINES *NUMERIC-ARG*
			#'(LAMBDA (LINE)
			    (MUNG-LINE LINE)
			    (SETF (AREF LINE 0) #\T)
			    (BDIRED-MARK-TRANSFER (BDIRED-LINE-CFILE LINE))))) 

(DEFCOM COM-BDIRED-UNDELETE "Un-mark file(s) for transfer.
Also cancels any other operation requested on the file.
This command is not currently supported by TI, but it works in most situations." ()
  (DIRED-MAP-OVER-LINES
    (IF (AND (NOT *NUMERIC-ARG-P*)
	     (OR (NOT (DIRED-LINE-PATHNAME (BP-LINE (POINT))))
		 (CHAR-EQUAL (BP-CHAR (BEG-LINE (POINT))) #\SPACE)))
	-1
	*NUMERIC-ARG*)
    #'(LAMBDA (LINE)
	(MUNG-LINE LINE)
	(SETF (AREF LINE 0) #\SPACE)
	(BDIRED-UNMARK-TRANSFER (BDIRED-LINE-CFILE LINE))))) 


(COMMENT;may want some of this later.
 ;;; An Inconsistency consists of two Cfiles and
 ;;; a group of consecutive Lines in a Buffer.
 (DEFSTRUCT (INCONSISTENCY
	      (:TYPE :NAMED-ARRAY)
	      :CONC-NAME)
   CFILE1
   CFILE2
   FIRST-LINE
   LAST-LINE)
 
 (DEFUN BDIRED-INSERT-INCONSISTENCY (CFILE1 CFILE2 STREAM)
   (LET* ((LINE1 (BDIRED-LIST-CFILE CFILE1 STREAM))
	  (LINE2 (BDIRED-LIST-CFILE CFILE2 STREAM))
	  (LINE3 (PROGN (WRITE-CHAR #\NEWLINE STREAM)
			(BDIRED-PREVIOUS-LINE STREAM)))
	  (INCONSISTENCY (MAKE-INCONSISTENCY FIRST-LINE LINE1
					     LAST-LINE LINE3
					     CFILE1 CFILE1
					     CFILE2 CFILE2)))
     (PUT-LINE LINE1 INCONSISTENCY 'BDIRED-INCONSISTENCY)
     (PUT-LINE LINE2 INCONSISTENCY 'BDIRED-INCONSISTENCY)
     (PUT-LINE LINE3 INCONSISTENCY 'BDIRED-INCONSISTENCY)
     LINE1))
 
 (DEFSUBST BDIRED-DELETE-INCONSISTENCY (INCONSISTENCY)
   (BDIRED-DELETE-LINE (INCONSISTENCY-FIRST-LINE INCONSISTENCY)
		       (INCONSISTENCY-LAST-LINE INCONSISTENCY)))
 
 (DEFSUBST RELATED-INCONSISTENCY (LINE)
   (GET-LINE LINE 'BDIRED-INCONSISTENCY))
 
 (DEFUN INCONSISTENCY-RELATED-CFILE (INCONSISTENCY CFILE)
   (COND ((EQ CFILE (INCONSISTENCY-CFILE1 INCONSISTENCY))
	  (INCONSISTENCY-CFILE2 INCONSISTENCY))
	 ((EQ CFILE (INCONSISTENCY-CFILE2 INCONSISTENCY))
	  (INCONSISTENCY-CFILE1 INCONSISTENCY))
	 (T
	  (ERROR "Cfile not element of Inconsistency" (LIST CFILE INCONSISTENCY)))))
 
 (DEFCOM COM-BDIRED-RESOLVE-INCONSISTENCY "Alter the other file's version/creation date.
When pointing at one file of an inconsistency, alters the version/creation-date
information of the other file to match this file.
This command is not currently supported by TI, but it works in most situations." ()
   (LET* ((LINE (BP-LINE (POINT)))
	  (CORRECT-CFILE (BDIRED-LINE-CFILE LINE))
	  (INCONSISTENCY (OR (RELATED-INCONSISTENCY LINE)
			     (BARF "Not an inconsistency")))
	  (INCORRECT-CFILE (INCONSISTENCY-RELATED-CFILE INCONSISTENCY CORRECT-CFILE))
	  (V1 (FS::CFILE-VERSION CORRECT-CFILE))
	  (V2 (FS::CFILE-VERSION INCORRECT-CFILE))
	  (CD1 (FS::CFILE-CREATION-DATE CORRECT-CFILE))
	  (CD2 (FS::CFILE-CREATION-DATE INCORRECT-CFILE))
	  (TRUENAME (FS::CFILE-TRUENAME INCORRECT-CFILE)))
     (COND ((AND (= V1 V2) (/= CD1 CD2))
	    (BDIRED-CHANGE-CREATION-DATE TRUENAME CD1))
	   ((= CD1 CD2)
	    (BDIRED-CHANGE-VERSION TRUENAME V1))
	   ((/= CD1 CD2)
	    (BDIRED-CHANGE-VERSION-AND-CREATION-DATE TRUENAME V1 CD1)))
     (BDIRED-DELETE-INCONSISTENCY INCONSISTENCY))
   DIS-TEXT)
 
 (DEFUN BDIRED-CHANGE-CREATION-DATE (TRUENAME DATE)
   (WITH-OPEN-FILE (STREAM TRUENAME :DIRECTION :INPUT)
     (SEND STREAM :CHANGE-PROPERTIES NIL :CREATION-DATE DATE))
   (FORMAT *QUERY-IO*
	   "~&Creation date of ~A changed to ~A"
	   TRUENAME
	   (TIME:PRINT-UNIVERSAL-TIME DATE NIL)))
 
 (DEFUN BDIRED-CHANGE-VERSION (TRUENAME VERSION)
   (LET ((NEWNAME (SEND TRUENAME :NEW-VERSION VERSION)))
     (WITH-OPEN-FILE (STREAM TRUENAME :DIRECTION :INPUT)
       (SEND STREAM ':RENAME NEWNAME))
     (FORMAT *QUERY-IO* "~&~A renamed to ~A" TRUENAME NEWNAME)))
 
 (DEFUN BDIRED-CHANGE-VERSION-AND-CREATION-DATE (TRUENAME VERSION DATE)
   (LET ((NEWNAME (SEND TRUENAME :NEW-VERSION VERSION)))
     (WITH-OPEN-FILE (STREAM TRUENAME :DIRECTION :INPUT)
       (SEND STREAM :RENAME NEWNAME)
       (SEND STREAM :CHANGE-PROPERTIES NIL :CREATION-DATE DATE))
     (FORMAT *QUERY-IO*
	     "~&~A renamed to ~A;~%creation date changed to ~A"
	     TRUENAME
	     NEWNAME
	     (TIME:PRINT-UNIVERSAL-TIME DATE NIL))))) 

;;;; Documentation

(DEFCOM COM-BDIRED-DOCUMENTATION "Print various sorts of editor documentation.
This command is not currently supported by TI, but it works in most situations." ()
  (LET ((*COM-DOCUMENTATION-ALIST* (CONS '(#\M COM-BDIRED-HELP)
					 *COM-DOCUMENTATION-ALIST*)))
    (COM-DOCUMENTATION))) 


(DEFCOM COM-BDIRED-HELP "Explain use of BDIRED commands.
This command is not currently supported by TI, but it works in most situations." ()
  (FORMAT T
	  "You are in the balance directories editor.  The commands are:
	T	Mark the current file to be transferred.
	P	Print the current file on the standard hardcopy device.
	U	Undelete the current file, or else the file just above the cursor.
		Also used to cancel a Print request.
	R	Rename this file.  You type the new filename in a mini buffer.
	C	Copy this file.  You type the new filename in a mini buffer.
	Rubout	Undelete file above the cursor.
	Space	Move to the next line.
	  Above commands repeat with a numeric argument,
	  backwards if the argument is negative.	  
	Q (or END)  Exit.  The remaining files in the transfer lists will be moved.
	ABORT	Exit without performing any transfers.
	=	SRCCOM this file with the > version.
")
  DIS-NONE) 
