Return to %SYSPOLY.m CVS log

Up to [Coherent Logic Development] / freem / mlib

Phase 3 of REUSE compliance and header reformatting

%SYSPOLY ;V4W/DLW-FREEM POLYFILLS; 9/2/2021 7:52 PM
    ;0.0;FreeM;****FREEM**;Serena Willis @2021
    ; 
    ;   $Id: %SYSPOLY.m,v 1.3 2025/03/10 00:38:15 snw Exp $
    ;    FreeM Polyfills
    ;
    ;
    ;   Author: David Wicksell <dlwicksell@fourthwatchsoftware.com>
    ;    Copyright (C) 1998 MUG Deutschland
    ;    Copyright (C) 2020, 2021, 2023 Fourth Watch Software LC
    ;
    ;
    ;   This file is part of FreeM.
    ;
    ;   FreeM is free software: you can redistribute it and/or modify
    ;   it under the terms of the GNU Affero Public License as published by
    ;   the Free Software Foundation, either version 3 of the License, or
    ;   (at your option) any later version.
    ;
    ;   FreeM is distributed in the hope that it will be useful,
    ;   but WITHOUT ANY WARRANTY; without even the implied warranty of
    ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    ;   GNU Affero Public License for more details.
    ;
    ;   You should have received a copy of the GNU Affero Public License
    ;   along with FreeM.  If not, see <https://www.gnu.org/licenses/>.
    ;
    ;   $Log: %SYSPOLY.m,v $
    ;   Revision 1.3  2025/03/10 00:38:15  snw
    ;   Phase 3 of REUSE compliance and header reformatting
    ;
    ;
    ; SPDX-FileCopyrightText:  (C) 2025 Coherent Logic Development LLC
    ; SPDX-License-Identifier: AGPL-3.0-or-later    
MERGE(SOURCE,DESTINATION) ; Implement the MERGE command
	; SOURCE = M array to merge from passed by name indirection
	; DESTINATION = M array to merge to passed by name indirection
	; returns 0 on success, -1 on error
	;
	; SOURCE is an array descendant of DESTINATION; throw M19 (error code 158)
	IF $EXTRACT(SOURCE,1,$LENGTH(DESTINATION))=DESTINATION QUIT -1
	; DESTINATION is an array descendant of SOURCE; throw M19 (error code 158)
	IF $EXTRACT(DESTINATION,1,$LENGTH(SOURCE))=SOURCE QUIT -1
	;
	; save SOURCE and DESTINATION in order to reset the naked indicator at the end
	NEW SAVESRC,SAVEDST
	SET SAVESRC=SOURCE,SAVEDST=DESTINATION
	;
	; set DESTINATION clear base name
	NEW DST
	SET DST=DESTINATION
	;
	; set SOURCE break flag
	NEW SRC
	SET SRC=SOURCE,$QSUBSCRIPT(SRC,0)="",$EXTRACT(SRC,$LENGTH(SRC))=""
	;
	; set the SOURCE POP offset
	NEW POP
	IF $QLENGTH(SOURCE)>$QLENGTH(DESTINATION) SET POP=$QLENGTH(SOURCE)-$QLENGTH(DESTINATION)
	ELSE  SET POP=0
	;
	; set the DESTINATION PUSH offset
	NEW PUSH
	IF $QLENGTH(DESTINATION)>$QLENGTH(SOURCE) SET PUSH=$QLENGTH(DESTINATION)-$QLENGTH(SOURCE)
	ELSE  SET PUSH=0
	;
	; merge initial node, if it exists
	SET:$DATA(@SOURCE)#2 @DESTINATION=@SOURCE
	;
	; merge the rest of the nodes
	NEW I,TST
	FOR  SET SOURCE=$QUERY(@SOURCE) QUIT:(SOURCE="")!(SRC=-1)  DO
	. ; quit at the end of a SOURCE sub-tree
	. SET TST=SOURCE,$QSUBSCRIPT(TST,0)="",TST=$EXTRACT(TST,1,$LENGTH(SRC))
	. IF TST'=SRC SET SRC=-1 QUIT
	. ;
	. ; clear DESTINATION keys
	. SET DESTINATION=DST
	. ; rebuild the DESTINATION array keys
	. FOR I=1:1:($QLENGTH(SOURCE)-POP) DO
	. . SET $QSUBSCRIPT(DESTINATION,I+PUSH)=$QSUBSCRIPT(SOURCE,I+POP)
	. ;
	. ; set the next node
	. SET @DESTINATION=@SOURCE
	;
	; reset the naked indicator
	SET SAVESRC=$GET(@SAVESRC),SAVEDST=$GET(@SAVEDST)
	;
	QUIT 0
REVQUERY(CURRENT,PREVIOUS) ; Implement reverse $QUERY
	; CURRENT = global or local query reference passed by name indirection
	; PREVIOUS = previous global or local node, regardless of depth, passed by reference
	; returns 0
	;
	; if root node, return the empty string
	IF $QLENGTH(CURRENT)=0 SET PREVIOUS="" QUIT 0
	ELSE  SET PREVIOUS=CURRENT
	;
	NEW FLAG SET FLAG=0
	NEW I,SUB
	; loop backwards, stripping off subscript levels on the same line
	FOR I=1:1:$QLENGTH(CURRENT) QUIT:FLAG  DO
	. SET SUB=$ORDER(@PREVIOUS,-1)
	. SET PREVIOUS=$NAME(@PREVIOUS,$QLENGTH(PREVIOUS)-1)
	. ;
	. ; if we moved to a new line, start looking forward
	. IF SUB'="" DO  SET FLAG=1
	. . SET PREVIOUS=$NAME(@PREVIOUS@(SUB))
	. . ;
	. . NEW SAVE
	. . ; loop forwards until we hit the original node
	. . FOR  DO  QUIT:(PREVIOUS="")  QUIT:($NAME(@PREVIOUS)=$NAME(@CURRENT))
	. . . ; save off the correct previous node to return
	. . . SET SAVE=PREVIOUS
	. . . SET PREVIOUS=$QUERY(@PREVIOUS)
	. . ;
	. . SET PREVIOUS=SAVE
        . ELSE  IF $DATA(@PREVIOUS)#2 SET FLAG=1
	;
	; if root node doesn't exist, return the empty string
	SET:(($QLENGTH(PREVIOUS)=0)&($DATA(@PREVIOUS)#2=0)) PREVIOUS=""
	;
	QUIT 0