(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED "29-Jul-88 20:37:15" {QV}<NOTECARDS>1.3LNEXT>RHTPATCH327.;5 30886
changes to%: (VARS RHTPATCH327COMS)
(FNS NC.FixUpLinksInCardCopy NC.FixUpCrossFileLinksInCardCopies NC.CopyCards)
previous date%: "22-Jul-88 00:12:57" {QV}<NOTECARDS>1.3LNEXT>RHTPATCH327.;1)
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT RHTPATCH327COMS)
(RPAQQ RHTPATCH327COMS
((DECLARE%: DONTCOPY (PROPS (RHTPATCH327 MAKEFILE-ENVIRONMENT)
(RHTPATCH327 FILETYPE)))
(* ;; "Can now do CopyCards on a set of cards distributed among several notefiles. Also, CopyCards will %"fix up%" UIDs for cardtypes if the cardtype atom has a ReplaceUIDsFn property. Fixed NC.UpperLeftCH# so that we won't get calls to the bitmap editor when recomputing tabletops whose cards have bitmaps in upper left corners of their windows.")
(* ;; "New function for NCDATABASE")
(FNS NC.FixUpCrossFileLinksInCardCopies)
(* ;; "Change to NCDATABASE")
(FNS NC.CopyCards NC.FixUpLinksInCardCopy)
(* ;; "Change to NCUTILITIES")
(FNS NC.UpperLeftCH#)))
(DECLARE%: DONTCOPY
(PUTPROPS RHTPATCH327 MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
(PUTPROPS RHTPATCH327 FILETYPE :TCOMPL)
)
(* ;;
"Can now do CopyCards on a set of cards distributed among several notefiles. Also, CopyCards will %"fix up%" UIDs for cardtypes if the cardtype atom has a ReplaceUIDsFn property. Fixed NC.UpperLeftCH# so that we won't get calls to the bitmap editor when recomputing tabletops whose cards have bitmaps in upper left corners of their windows."
)
(* ;; "New function for NCDATABASE")
(DEFINEQ
(NC.FixUpCrossFileLinksInCardCopies
[LAMBDA (Cards) (* ; "Edited 29-Jul-88 19:00 by Trigg")
(* ;; "For each card in NewCards, see if it was marked as having internal cross-file links. If so, replace them with normal links.")
(for Card in Cards bind CrossFileLinksToFix when (SETQ CrossFileLinksToFix (NC.FetchUserDataProp
Card
'CrossFileLinksToFix)
)
do (for Link in (CAR (NC.ApplyFn CollectLinksFn Card)) eachtime (BLOCK) bind PreviousLink
do (LET (NewDestCard NewLink)
[if [SETQ NewDestCard (for CrossFileLinkInfo in CrossFileLinksToFix
when (NC.SameLinkP Link (CAR CrossFileLinkInfo))
do (RETURN (CADR CrossFileLinkInfo]
then (SETQ NewLink (NC.MakeLink NIL (fetch (Link Label) of Link)
NewDestCard Card (fetch (Link DisplayMode)
of Link)
(fetch (Link AnchorMode) of Link)
NIL NIL PreviousLink))
(* ;
"Smash the imageobj's link with contents of new one we just made.")
(for FieldName in (RECORDFIELDNAMES 'Link)
do (RECORDACCESS FieldName Link (RECLOOK 'Link)
'REPLACE
(RECORDACCESS FieldName NewLink (RECLOOK 'Link)
'FETCH]
(SETQ PreviousLink Link)))
(NC.SetUserDataProp Card 'CrossFileLinksToFix NIL])
)
(* ;; "Change to NCDATABASE")
(DEFINEQ
(NC.CopyCards
[LAMBDA (Cards DestNoteFileOrFileBox RootCards QuietFlg InterestedWindow CopyExternalToLinksMode)
(* ; "Edited 29-Jul-88 18:23 by Trigg")
(* ;;; "Create copies of cards in Cards. If DestNoteFileOrFileBox is a notefile, then destination will be the contents box in that notefile, else the FileBox's notefile. RootCards should be NIL or a subset of Cards. If NIL, then file all Cards in the dest filebox. Otherwise, just file RootCards in that filebox and assume others are linked somehow to the RootCards. Links between cards in Cards are copied, but links from or to outside cards aren't.")
(* ;;; "Currently all Cards must be in same notefile, but this perhaps could be relaxed if could prevent possibility of two cards in different notefiles having the same UID.")
(* ;; "kirk 24Apr86 Added calls to select cards if none provided")
(* ;; "rht 9/2/86: Added InterestedWindow arg.")
(* ;; "pmi 12/12/86: Removed obsolete ReturnLinksFlg argument in call to NC.SelectNoteCards.")
(* ;; "rg 3/18/87 added NC.CardSelectionOperation wrapper")
(* ;; "rg 4/2/87 changed NC.CardSelectionOperation to NCP.WithLockedCards ; added NC.IfAllCardsFree wrapper")
(* ;; "rht&rg&pmi 4/22/87: No longer calls ERROR!")
(* ;; "rg 6/2/87 was checking for CANCELLED instead of DON'T")
(* ;; "rg 6/5/87 deletes new cards if we cancel out halfway through")
(* ;; "rht 6/6/87: Now optionally copies 'external' links. Passes extra new args to NC.FixUpLinksInCardCopy.")
(* ;; "rht 6/22/87: Now returns list of cards copied, like it used to.")
(* ;; "pmi 10/29/87: Now returns list of card copies, instead of cards copied.")
(* ;; "pmi 12/10/87: Now returns new cards in the same order as their corresponding original cards. At dsj's suggestion (and implementation), now can pass (QUOTE NONE) as RootCards, meaning don't file any of the new cards in the destination filebox.")
(* ;; "dsj. 2/23/88. Fixed bug with (QUOTE NONE) arg.")
(* ;; "rht 7/21/88: When asking for dest filebox, now passes NC.FileBoxP predicate to NC.SelectNoteCards. Also now calls card type's ReplaceUIDsFn in case the card to copy has uid's appearing in its substance.")
(* ;; "rht 7/29/88: No longer requires all cards to live in same notefile.")
(NCP.WithLockedCards
(NC.IfAllCardsFree
(NC.LockListOfCards Cards "Copy Cards")
(PROG (NumCards SourceNoteFile DestNoteFile BoxToFileIn TempStream CardHashArray LinksHashArray
CurrentLinkLabels NewLinkLabels NewCardsAndLocsOnStream CopyExternalToLinksFlg
NewCardList)
(* ;; "Make sure the arguments are valid.")
(if (NULL Cards)
then (if (NULL (SETQ Cards (NC.SelectNoteCards NIL NIL NC.SelectingCardsMenu NIL
"Shift-select cards to copy:" NIL)))
then (RETURN NIL)))
(SETQ Cards (MKLIST Cards))
(SETQ NumCards (LENGTH Cards)) (* ;
"All Cards to copy must live in open notefiles.")
(for Card in (MKLIST Cards) bind SourceNoteFile
unless (AND (type? NoteFile (SETQ SourceNoteFile (fetch (Card NoteFile) of Card)))
(OPENP (fetch (NoteFile Stream) of SourceNoteFile)))
do (NC.ReportError "NC.CopyCards" (CONCAT (fetch (NoteFile FullFileName) of
SourceNoteFile
)
" not an open notefile.")))
(* ;
"Compute dest notefile and dest filebox.")
(if (NOT DestNoteFileOrFileBox)
then (if (EQ 'DON'T (SETQ DestNoteFileOrFileBox (NC.SelectNoteCards
T
(FUNCTION NC.FileBoxP)
NC.SelectingCardMenu NIL
"Shift-select the FileBox to contain these cards."
T)))
then (RETURN NIL)))
(if (type? NoteFile DestNoteFileOrFileBox)
then (SETQ DestNoteFile DestNoteFileOrFileBox)
(SETQ BoxToFileIn (fetch (NoteFile TableOfContentsCard) of DestNoteFile))
elseif (NCP.FileBoxP DestNoteFileOrFileBox)
then (SETQ BoxToFileIn DestNoteFileOrFileBox)
(SETQ DestNoteFile (fetch (Card NoteFile) of BoxToFileIn))
else (NC.ReportError "NC.CopyCards" (CONCAT "Arg not notefile or filebox: "
DestNoteFileOrFileBox)))
(if [NOT (AND (type? NoteFile DestNoteFile)
(OPENP (fetch (NoteFile Stream) of DestNoteFile]
then (NC.ReportError "NC.CopyCards" (CONCAT (fetch (NoteFile FullFileName)
of DestNoteFile)
" not an open notefile.")))
(* ;;; "dsj. Fixed bug here by switching the order of the next two Sexprs.")
(if (NULL RootCards)
then (SETQ RootCards Cards)
elseif (EQ RootCards 'NONE)
then (SETQ RootCards))
(if (LDIFFERENCE (SETQ RootCards (MKLIST RootCards))
Cards)
then (NC.ReportError "NC.CopyCards"
"RootCards argument not subset of Cards argument."))
(* ;;; "Figure out whether to copy 'external' links.")
[SETQ CopyExternalToLinksFlg (SELECTQ CopyExternalToLinksMode
(COPY T)
(DON'TCOPY NIL)
(SELECTQ (NC.AskUserWithMenu '(Yes No Cancel)
(CONCAT "You've asked to copy "
(LENGTH Cards)
" cards."
(CHARACTER 13)
"Links among these cards will be automatically copied."
(CHARACTER 13)
"Do you also want to copy links pointing from these cards to elsewhere? "
)
InterestedWindow)
(Yes T)
(No NIL)
(RETURN NIL]
(* ;;; "Now get to work.")
(SETQ TempStream (OPENSTREAM '{NODIRCORE} 'BOTH))
(SETQ CurrentLinkLabels (NC.RetrieveLinkLabels DestNoteFile))
(SETQ NewLinkLabels (TCONC NIL))
(SETQ LinksHashArray (HASHARRAY NC.CopyCardsLinksHashArraySize NIL (FUNCTION
NC.MakeHashKey)
(FUNCTION NC.SameUIDP)))
(SETQ CardHashArray (HASHARRAY NumCards NIL (FUNCTION NC.MakeHashKeyFromCard)
(FUNCTION NC.SameCardP)))
(* ;; "Create new cards in DestNoteFile for each card. Make these cards by copying original cards to a temp stream. Keep track of UID mappings between original cards and card copies using CardHashArray.")
(OR QuietFlg (NC.PrintMsg InterestedWindow T "Copying cards: creating empty copies."
(CHARACTER 13)
"Processing item " 1 " out of " NumCards "..." (CHARACTER 13)))
(SETQ NewCardsAndLocsOnStream NIL)
(RESETLST
[RESETSAVE NIL '(PROGN (if RESETSTATE
then (for CardAndLoc in NewCardsAndLocsOnStream
do (NC.DeleteNoteCardInternal (CAR CardAndLoc)
T InterestedWindow))
(NC.ClearMsg InterestedWindow T]
(for Card in Cards as i from 1 bind NewCard WasActiveFlg HadStatusNILFlg IndexLocs
eachtime (BLOCK) unless (NC.CrossFileLinkCardP Card)
do [OR QuietFlg (if (ZEROP (REMAINDER i 100))
then (NC.PrintMsg InterestedWindow T
"Copying cards: creating empty copies."
(CHARACTER 13)
"Processing item " i " out of " NumCards "..."
(CHARACTER 13]
(if (NOT (SETQ WasActiveFlg (NC.ActiveCardP Card)))
then (NC.GetNoteCard Card))
(if (SETQ HadStatusNILFlg (NULL (fetch (Card Status) of Card)))
then (* ;
"Have to have Status slot ACTIVE in order that Put to stream won't break.")
(replace (Card Status) of Card with 'ACTIVE))
(SETQ IndexLocs (NC.PutNoteCardToStream Card NIL T TempStream))
(if HadStatusNILFlg
then (replace (Card Status) of Card with NIL))
(if (NOT WasActiveFlg)
then (NC.DeactivateCard Card)) (* ; "Make new empty card for copy.")
(SETQ NewCard (NC.GetNewCard DestNoteFile))
(* ; "Map old cards to card copies.")
(PUTHASH Card NewCard CardHashArray)
(push NewCardsAndLocsOnStream (CONS NewCard IndexLocs))))
(* ;; "For each card, get it off the temp stream, fix its links, fix browser info if necessary, and write it down to the dest notefile.")
(SETFILEPTR TempStream 0)
(OR QuietFlg (NC.PrintMsg InterestedWindow T
"Copying cards: fixing links and browser cards." (CHARACTER 13)
"Processing item " 1 " out of " NumCards "..." (CHARACTER 13)))
(SETQ NewCardList)
(for NewCardAndLocsOnStream in NewCardsAndLocsOnStream as i from 1 eachtime (BLOCK)
bind (CrossFileLinkModePropList ← (LIST DestNoteFile NIL))
do [OR QuietFlg (if (ZEROP (REMAINDER i 100))
then (NC.PrintMsg InterestedWindow T
"Copying cards: fixing links and browser cards."
(CHARACTER 13)
"Processing item " i " out of " NumCards "..."
(CHARACTER 13]
(LET ((NewCard (CAR NewCardAndLocsOnStream))
(IndexLocs (CDR NewCardAndLocsOnStream)))
(* ;
"Have to make status active for Get fns to work.")
(NC.SetStatus NewCard 'ACTIVE)
(NC.GetNoteCardFromStream NewCard TempStream IndexLocs)
(NC.FixUpLinksInCardCopy NewCard CardHashArray LinksHashArray
CurrentLinkLabels NewLinkLabels InterestedWindow CopyExternalToLinksFlg
CrossFileLinkModePropList)
(if (NC.IsSubTypeOfP (NC.FetchType NewCard)
'Browser)
then (NC.FixUpBrowserCardCopy NewCard CardHashArray))
(* ;; "Fix up the uid's if this card type's substance contains uid's of other cards. (Ideally, the above call to NC.FixUpBrowserCardCopy would be done with ReplaceUIDsFn, but until that becomes a real slot of the card type, we can't be sure that card types inheriting from Browser would have the ReplaceUIDsFn prop.)")
(LET [(ReplaceUIDsFn (GETPROP (NC.FetchType NewCard)
'ReplaceUIDsFn]
(if ReplaceUIDsFn
then (APPLY* ReplaceUIDsFn NewCard CardHashArray)))
(NC.PutNoteCard NewCard)
(push NewCardList NewCard)))
(* ;; "Have to go back and replace any internal cross-file links with normal links.")
(NC.FixUpCrossFileLinksInCardCopies NewCardList)
(* ;; "Link RootCards under filebox in DestNotefile.")
(OR QuietFlg (NC.PrintMsg InterestedWindow T "Copying cards: filing " (LENGTH RootCards)
" new cards in "
(NC.FetchTitle BoxToFileIn)
"..."
(CHARACTER 13)))
(AND RootCards (NC.FileBoxCollectChildren NIL BoxToFileIn (for RootCard in RootCards
eachtime (BLOCK)
collect (GETHASH RootCard
CardHashArray
))
T))
(* ;; "Put out any new link labels to the dest notefile.")
(AND (SETQ NewLinkLabels (CDAR NewLinkLabels))
(NC.StoreLinkLabels DestNoteFile (APPEND NewLinkLabels CurrentLinkLabels)))
(OR QuietFlg (NC.ClearMsg InterestedWindow T))
(RETURN NewCardList])
(NC.FixUpLinksInCardCopy
[LAMBDA (CardCopy CardHashArray LinksHashArray CurrentLinkLabels NewLinkLabels InterestedWindow
CopyExternalToLinksFlg CrossFileLinkModePropList)
(* ; "Edited 29-Jul-88 19:16 by Trigg")
(* ;;; "For all the links from or to CardCopy, change other endpoint's card according to mapping table in CardHashArray. If other endpoint is a card not found in the hash array, then drop that link altogether. The mapping from old link UIDs to new ones is in LinksHashArray. Any new link labels not in CurrentLinkLabels get TCONC'ed onto NewLinkLabels.")
(* ;;
"rht 2/17/86: Now uses NC.ApplyFn instead of APPLY* for deleting and collecting references.")
(* ;; "rht 11/1/86: Added missing var bindings and a BLOCK")
(* ;; "rht 6/6/87: Added new args InterestedWindow, CopyExternalToLinksFlg, and CrossFileLinkModePropList to handle optional copying of external links.")
(* ;; "rht 7/29/88: Now handles case when dest card is a cross-file link card and remote dest card is one we're supposed to copy. That is, we replace the cross-file link with a normal link between the copies.")
(LET ((CardCopyType (NC.FetchType CardCopy)))
(* ;; "Fix all the From links.")
(NC.SetFromLinks CardCopy (for Link in (NC.FetchFromLinks CardCopy) eachtime (BLOCK)
bind SourceCard OldLinkUID LinkLabel
when (SETQ SourceCard (GETHASH (fetch (Link SourceCard)
of Link)
CardHashArray))
collect (replace (Link DestinationCard) of Link with CardCopy)
(replace (Link SourceCard) of Link with SourceCard)
(replace (Link UID) of Link
with (OR (GETHASH (SETQ OldLinkUID (fetch (Link UID)
of Link))
LinksHashArray)
(PUTHASH OldLinkUID (NC.MakeUID)
LinksHashArray)))
(* ;
"Keep track of link labels in case any are new.")
(OR (FMEMB (SETQ LinkLabel (fetch (Link Label)
of Link))
CurrentLinkLabels)
(NC.SystemLinkLabelP LinkLabel)
(FMEMB LinkLabel (CAR NewLinkLabels))
(TCONC NewLinkLabels LinkLabel))
Link))
(* ;; "Do it all again for the To links.")
(NC.SetToLinks CardCopy (for Link in (NC.FetchToLinks CardCopy) eachtime (BLOCK)
bind DestCard OldLinkUID LinkLabel
when (SETQ DestCard (GETHASH (fetch (Link DestinationCard)
of Link)
CardHashArray))
collect (replace (Link SourceCard) of Link with CardCopy)
(replace (Link DestinationCard) of Link with DestCard)
(replace (Link UID) of Link
with (OR (GETHASH (SETQ OldLinkUID (fetch (Link UID)
of Link))
LinksHashArray)
(PUTHASH OldLinkUID (NC.MakeUID)
LinksHashArray)))
(* ;
"Keep track of link labels in case any are new.")
(OR (FMEMB (SETQ LinkLabel (fetch (Link Label) of Link))
CurrentLinkLabels)
(NC.SystemLinkLabelP LinkLabel)
(FMEMB LinkLabel (CAR NewLinkLabels))
(TCONC NewLinkLabels LinkLabel))
Link))
(* ;; "Now fix the links inside imageobj's in the card's substance.")
(AND (fetch (Card LinkAnchorModesSupported) of CardCopy)
(for Link in (CAR (NC.ApplyFn CollectLinksFn CardCopy)) eachtime (BLOCK) bind
PreviousLink
do (LET ((DestCard (fetch (Link DestinationCard) of Link))
(LinkLabel (fetch (Link Label) of Link))
OldLinkUID DestCardCopy RemoteDestCard NewLink)
(COND
((AND (NC.CrossFileLinkCardP DestCard)
(SETQ RemoteDestCard (NC.GetCrossFileLinkDestCard DestCard
InterestedWindow))
(SETQ DestCardCopy (GETHASH RemoteDestCard CardHashArray)))
(* ; "It's an internal cross-file link. Mark the card as needing its cross-file link replaced by a non-cross-file link.")
[NC.SetUserDataProp CardCopy 'CrossFileLinksToFix
(CONS (LIST Link DestCardCopy)
(NC.FetchUserDataProp CardCopy 'CrossFileLinksToFix]
(* ;
"Keep track of link labels in case any are new.")
(OR (FMEMB LinkLabel CurrentLinkLabels)
(NC.SystemLinkLabelP LinkLabel)
(FMEMB LinkLabel (CAR NewLinkLabels))
(TCONC NewLinkLabels LinkLabel))
(SETQ PreviousLink Link))
((SETQ DestCardCopy (GETHASH DestCard CardHashArray))
(replace (Link SourceCard) of Link with CardCopy)
(replace (Link DestinationCard) of Link with DestCardCopy)
(replace (Link UID) of Link with (OR (GETHASH (SETQ OldLinkUID
(fetch (Link UID)
of Link))
LinksHashArray)
(PUTHASH OldLinkUID (NC.MakeUID)
LinksHashArray)))
(SETQ PreviousLink Link))
(* ;;
"It's an external link. Try to make a copy, possibly resulting in a cross-file link.")
([AND CopyExternalToLinksFlg (if (NC.CrossFileLinkCardP DestCard)
then (SETQ DestCard (
NC.GetCrossFileLinkDestCard
DestCard
InterestedWindow))
else DestCard)
(SETQ NewLink (NC.MakeLink NIL LinkLabel DestCard CardCopy
(fetch (Link DisplayMode) of Link)
(fetch (Link AnchorMode) of Link)
NIL NIL PreviousLink (
NC.ComputeCrossFileLinkMode
DestCard
CrossFileLinkModePropList
InterestedWindow]
(* ;
"Smash the imageobj's link with contents of new one we just made.")
[for FieldName in (RECORDFIELDNAMES 'Link)
do (RECORDACCESS FieldName Link (RECLOOK 'Link)
'REPLACE
(RECORDACCESS FieldName NewLink (RECLOOK 'Link)
'FETCH] (* ;
"Keep track of link labels in case any are new.")
(OR (FMEMB LinkLabel CurrentLinkLabels)
(NC.SystemLinkLabelP LinkLabel)
(FMEMB LinkLabel (CAR NewLinkLabels))
(TCONC NewLinkLabels LinkLabel))
(SETQ PreviousLink Link))
(T (NC.ApplyFn DeleteLinksFn CardCopy Link])
)
(* ;; "Change to NCUTILITIES")
(DEFINEQ
(NC.UpperLeftCH#
[LAMBDA (TEditWindow) (* ; "Edited 21-Jul-88 21:32 by Trigg")
(* ;;
"Returns the character number of the first currently displayed character in a tedit window.")
(* ;; "rht 7/21/88: Fixed problem where bitmap in upper left corner of window caused bitmap editor to be run under call to TEDIT.SELECT. Did that by changing SELOPERATION arg from 'NORMAL to 'COPY. Also changed the REGION arg from (fetch (TEXTOBJ MOUSEREGION) of TextObj) to 'COPY.")
(LET ((TextObj (TEXTOBJ TEditWindow)))
(fetch (SELECTION CH#) of (TEDIT.SELECT 0 (SUB1 (fetch (TEXTOBJ WTOP) of TextObj))
TextObj
'TEXT NIL 'COPY TEditWindow])
)
(PUTPROPS RHTPATCH327 COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1887 4108 (NC.FixUpCrossFileLinksInCardCopies 1897 . 4106)) (4147 29935 (NC.CopyCards
4157 . 19428) (NC.FixUpLinksInCardCopy 19430 . 29933)) (29975 30803 (NC.UpperLeftCH# 29985 . 30801))))
)
STOP