(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED " 4-Aug-88 21:42:06" {QV}<NOTECARDS>1.3LNEXT>RHTPATCH331.;1 13742
changes to%: (VARS RHTPATCH331COMS))
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT RHTPATCH331COMS)
(RPAQQ RHTPATCH331COMS ((DECLARE%: DONTCOPY (PROPS (RHTPATCH331 MAKEFILE-ENVIRONMENT)
(RHTPATCH331 FILETYPE)))
(* ;;
"Fixes bug reported by Dan Jordan whereby global links weren't being copied properly.")
(* ;; "Change to NCDATABASE")
(FNS NC.FixUpLinksInCardCopy)))
(DECLARE%: DONTCOPY
(PUTPROPS RHTPATCH331 MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
(PUTPROPS RHTPATCH331 FILETYPE :TCOMPL)
)
(* ;; "Fixes bug reported by Dan Jordan whereby global links weren't being copied properly.")
(* ;; "Change to NCDATABASE")
(DEFINEQ
(NC.FixUpLinksInCardCopy
[LAMBDA (CardCopy CardHashArray LinksHashArray CurrentLinkLabels NewLinkLabels InterestedWindow
CopyExternalToLinksFlg CrossFileLinkModePropList)
(* ; "Edited 4-Aug-88 21:35 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.")
(* ;; "rht 8/4/88: Now doesn't follow cross file links in order to check whether dest card is in set of copied cards.")
(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))
(* ;; "Yet again for global links. Don't have to mess with link labels here 'cause ToLinks loop took care of that.")
(NC.SetGlobalLinks CardCopy (for Link in (NC.FetchGlobalLinks CardCopy) eachtime (BLOCK)
bind DestCard OldLinkUID
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)))
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 NewLink)
(COND
((AND (NC.CrossFileLinkCardP DestCard)
(SETQ DestCardCopy (GETHASH (create Card
UID ← (fetch (
CrossFileLinkSubstance
CrossFileLinkDestCardUID
)
of (NCP.CardSubstance
DestCard)))
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))
([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]
(* ;;
"It's an external link. Try to make a copy, possibly resulting in a cross-file link.")
(* ;
"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])
)
(PUTPROPS RHTPATCH331 COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1088 13659 (NC.FixUpLinksInCardCopy 1098 . 13657)))))
STOP