File:  [Coherent Logic Development] / freem / mlib / %ulstring.m
Revision 1.2: download - view: text, annotated - select for diffs
Mon Mar 10 00:38:15 2025 UTC (3 weeks, 1 day ago) by snw
Branches: MAIN
CVS tags: v0-62-3, v0-62-2, v0-62-1, v0-62-0, HEAD
Phase 3 of REUSE compliance and header reformatting

%ulstring ;VCL/SNW-STRING LIBRARY; 03/09/25 06:30 PM
    ;0.0;FreeM;****FREEM**;Serena Willis @2025
    ;
    ;   $Id: %ulstring.m,v 1.2 2025/03/10 00:38:15 snw Exp $
    ;    String library
    ;
    ;  
    ;   Author: Serena Willis <snw@coherent-logic.com>
    ;    Copyright (C) 1998 MUG Deutschland
    ;    Copyright (C) 2023, 2025 Coherent Logic Development LLC
    ;
    ;
    ;   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: %ulstring.m,v $
    ;   Revision 1.2  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
    ;
    ; STRING library - version 0.5.0.1
    ;
    ; Unless otherwise noted, the code below
    ; was approved in document X11/95-11
    ;
    ; If corrections have been applied,
    ; first the original line appears,
    ; with three semicolons at the beginning of the line.
    ;
    ; Then the source of the correction is acknowledged,
    ; then the corrected line appears, followed by a
    ; line containing three semicolons.
    ;
    ;
    ;
PRODUCE(IN,SPEC,MAX) ;
 NEW VALUE,AGAIN,P1,P2,I,COUNT
 SET VALUE=IN,COUNT=0
 FOR  DO  QUIT:'AGAIN
 . SET AGAIN=0
 . SET I=""
 . FOR  SET I=$ORDER(SPEC(I)) QUIT:I=""  DO  QUIT:COUNT<0
 . . QUIT:$GET(SPEC(I,1))=""
 . . QUIT:'($DATA(SPEC(I,2))#2)
 . . FOR  QUIT:VALUE'[SPEC(I,1)  DO  QUIT:COUNT<0
 . . . SET P1=$PIECE(VALUE,SPEC(I,1),1)
 . . . SET P2=$PIECE(VALUE,SPEC(I,1),2,$LENGTH(VALUE))
 . . . SET VALUE=P1_SPEC(I,2)_P2,AGAIN=1
 . . . SET COUNT=COUNT+1
 . . . IF $DATA(MAX),COUNT>MAX SET COUNT=-1,AGAIN=0
 . . . QUIT
 . . QUIT
 . QUIT
 QUIT VALUE
 ;===
 ;
 ;
REPLACE(IN,SPEC) ;
 NEW L,MASK,K,I,LT,F,VALUE
 SET L=$LENGTH(IN),MASK=$JUSTIFY("",L)
 SET I="" FOR  SET I=$ORDER(SPEC(I)) QUIT:I=""  DO
 . QUIT:'($DATA(SPEC(I,1))#2)
 . QUIT:SPEC(I,1)=""
 . QUIT:'($DATA(SPEC(I,2))#2)
 . SET LT=$LENGTH(SPEC(I,1))
 . SET F=0 FOR  SET F=$FIND(IN,SPEC(I,1),F) QUIT:F<1  DO
 . . QUIT:$E(MASK,F-LT,F-1)["X"
 . . SET VALUE(F-LT)=SPEC(I,2)
 . . SET $EXTRACT(MASK,F-LT,F-1)=$TRANSLATE($JUSTIFY("",LT)," ","X")
 . . QUIT
 . QUIT
 SET VALUE="" FOR K=1:1:L DO
 . IF $EXTRACT(MASK,K)=" " SET VALUE=VALUE_$EXTRACT(IN,K) QUIT
 . SET:$DATA(VALUE(K)) VALUE=VALUE_VALUE(K)
 . QUIT
 QUIT VALUE
 ;===
 ;
 ;
FORMAT(V,L) ;
 ;
 ; The code below was approved in document X11/SC13/1998-10
 ;
 NEW C,CD,CM,CS,DP,E,EX,FL,FM,FO,GL,GV1,GV2,GVL,GVM,GX,I,J,K,ST,TV,TY,V1,V2,VP
 ;
 ; Load up Format Directives from ^$FORMAT or ^SYSTEM("FORMAT")
 DO:'$DATA(^$FORMAT) %INFORM
 SET (FM,K)="",EX=0,EXS="EXS"
 ;
 ; Extract the working values from the command string
 DO %PRELOAD
 ;
 ; Process the directives
 DO %EVALU8
 ;
 ; Error Handling
 DO:EX %ERROR
 XECUTE:$LENGTH(EXS) "K "_EXS
 QUIT K
 ;
 ; CM  - Command Array
 ; CS  - Command String
 ; DP  - Decimal Pointer
 ; EX  - Exit Flag
 ; EXS - KILL Exit String
 ; FL  - Field Length
 ; FM  - Format String
 ; FO  - Format Option Array
 ; K   - Return Output String
 ; L   - List of Directives
 ; ST  - String Extraction String
 ; V   - Input Value
 ;
%PRELOAD ; Load the defaults prior to the application of directives
 SET K=""
 ; Load System Defaults
 FOR  SET K=$ORDER(^$SYSTEM("FORMAT",K)) QUIT:K=""  DO
 . SET FO(K)=^$SYSTEM("FORMAT",K)
 . QUIT
 ; Load Process Defaults
 FOR  SET K=$ORDER(^$FORMAT(K)) QUIT:K=""  SET FO(K)=^$FORMAT(K)
 SET (CS,L)=$GET(L)
 ; Load Argument Overrides from the List of Directives
 ; 1. Tokenize the Laterals
 DO:L[""""
 . SET CS=""
 . FOR J=2:2:$LENGTH(L,"""") DO
 . . SET ST=$GET(ST)+1,ST(ST)=$PIECE(L,"""",J)
 . . SET:ST(ST)="" ST(ST)=""""
 . . SET CS=CS_$PIECE(L,"""",J-1)_"%%"_ST_"%%"
 . . QUIT
 . SET CS=CS_$PIECE(L,"""",J+1)
 . QUIT
 ; 2. Evaluate the Directives
 NEW C,L,X
 FOR J=1:1:$LENGTH(CS,":") DO  QUIT:EX
 . SET CD=$PIECE(CS,":",J)
 . SET X=$PIECE(CD,"="),TV=$PIECE(CD,"=",2,999)
 . IF X="" SET EX=1 QUIT
 . ; Uppercase Symbol Names Only
 . SET TY=$TRANSLATE(X,"abcdefghijklm","ABCDEFGHIJKLM")
 . SET TY=$TRANSLATE(TY,"nopqrstuvwxyz","NOPQRSTUVWXYZ")
 . D
 . . ; To bullet proof, Establish an error trap to %ERREX
 . . IF ($LENGTH(TV,"%%")>1) DO %LOADTV SET FO(TY)=TV QUIT
 . . IF TV="" SET FO(TY)="" QUIT
 . . ; 3. Set the Directive in the FO array
 . . SET FO(TY)=@TV
 . . QUIT
 . QUIT
 ; 4) Construct a KILL Exit String for directives not in default list
 NEW C,E
 SET (C,E)=""
 FOR  SET C=$ORDER(FO(C)) QUIT:C=""  SET @C=FO(C),E=E_C_","
 SET EXS=E_"EXS"
 SET:$DATA(FM) FL=$LENGTH(FM)
 QUIT
 ;
 ; DC  - Decimal Character
 ; DP  - Decimal Position
 ; EX  - Abnormal Condition Exit
 ; FL  - Format Length
 ; FM  - Format Mask
 ; GV1 - Integer Portion
 ; GV2 - Fractional Portion
 ; K   - Output Buffer
 ; NOD - No Decimal
 ; SV  - Sign Value (1 = Positive, 0 = Negative)
 ; V   - Input Value
%EVALU8 ; Evaluate the input for loading into the output string
 NEW NOD
 SET SV=1
 SET NOD='(FM["d")
 SET:V<0 SV=0
 SET V1=$PIECE(V,"."),V2=$PIECE(V,".",2),(GV1,GV2)=""
 DO:FM'=""
 . SET FL=$LENGTH(FM),DP=$FIND(FM,"d")-1
 . SET:(DP<1) DP=$LENGTH(FM)
 . QUIT
 NEW C
 DO %GETV1,%GETV2:'(NOD!EX)
 QUIT:EX
 ;
 SET K=GV1_DC_GV2
 SET:NOD K=GV1
 IF $GET(FC)'="" SET:K[" " K=$TRANSLATE(K," ",FC)
 SET:$LENGTH(K)'=FL EX=1
 QUIT
 ;
%GETV1 ; Get the integer portion of the value and lay it in GV1
 NEW CP,SP
 IF $GET(SL)'="" NEW SC SET SC=SL
 ; 1) Set the Integer Portion of the Mask (GVM) and Length (GVL)
 SET GVM=$PIECE(FM,"d"),GVL=$LENGTH(GVM),GL=0
 ; 2) Get the absolute value of V1
 SET:$EXTRACT(V1)="-" V1=$EXTRACT(V1,2,999)
 ; 3) Establish Blank Mask, GV1
 SET GV1=$J("",GVL),VP=$LENGTH(V1),(CP,SP)=1
 ;
 ; Rounding of Integer (NO DECIMAL PORTION)
 SET:$PIECE(FM,"d",2)="" V1=$EXTRACT((V+.5)\1,1,$LENGTH(V1))
 ; 4) Extract value for each position in the mask and set it
 FOR L=GVL:-1:1 SET C=$EXTRACT(GVM,L) DO QUIT:EX
 . SET GX=0
 . DO %TRANSV1
 . QUIT:GX!EX
 . ;
 . SET:GC'=" " $EXTRACT(GV1,L)=GC
 . QUIT
 SET:VP EX=1
 QUIT
 ;
%GETV2 ; Get the fractional portion of the value and lay it in GV2
 NEW CP,SP
 IF $GET(SR)'="" NEW SC SET SC=SR
 SET GVM=$PIECE(FM,"d",2),GVL=$LENGTH(GVM),GL=0,SP=1
 DO:GVL<$LENGTH(V2)  ; Rounding of Decimal
 . NEW J,N
 . SET N=$EXTRACT($TRANSLATE($J("",GVL)," ",0)_5_$TRANSLATE($J("",$LENGTH(V2))," ",0),1,$LENGTH(V2))
 . SET V2=$EXTRACT(V2+N,1,$LENGTH(V2))
 . QUIT
 SET GV2=$J("",GVL),VP=1,CP=1
 FOR L=1:1:GVL SET C=$EXTRACT(GVM,L) DO  QUIT:EX
 . SET GX=0
 . DO %TRANSV2
 . QUIT:GX!EX
 . ;
 . SET:GC'=" " $EXTRACT(GV2,L)=GC
 . QUIT
 QUIT
 ;
 ; C   - Current Mask Character from the FM
 ; CP  - Character Position
 ; L   - Position within
 ; VP  - Value Position
 ; (integer - Right to Left, fraction - Left to Right)
%TRANSV1 ; Translate the value into the mask
 SET (GC,GL)=" "
 QUIT:"x "[C
 ;
 ; Value Completed, Apply Currency/Float/etc, if requested
 IF 'VP DO
 . IF "c"[C  DO  QUIT
 . . SET:$GET(CP)="" CP=$LENGTH(CS)
 . . SET GC=$EXTRACT(CS,CP),CP=CP-1
 . . SET:CP<1 CP=$LENGTH(CS)
 . . QUIT
 . IF GVM["f"  DO  QUIT
 . . NEW F,I,LI,LX,X,Q
 . . SET X=" ",LI=L,LX=0
 . . DO  ; Identify the Value Represented
 . . . IF GVM["+"!(GVM["-") DO  QUIT
 . . . . SET:GVM["+" X="+"
 . . . . SET:V<0 X="-"
 . . . . QUIT
 . . . IF GVM["(" DO:V<0  QUIT
 . . . . SET X=" ",LX=1
 . . . . QUIT
 . . . QUIT
 . . FOR I=L:1:GVL SET Q=$EXTRACT(GV1,I) QUIT:Q?1N  QUIT:("("_DC)[Q  DO
 . . . SET F=$EXTRACT(GVM,I),LI=I
 . . . SET:"fs("[F $EXTRACT(GV1,I)=X
 . . . QUIT
 . . SET BYE=1
 . . SET:LX $EXTRACT(GV1,LI)="("
 . . QUIT
 . QUIT
 IF C="+" SET GC="+" SET:'SV GC="-" SET GL=GC QUIT
 IF C="-" SET:'SV GC="-" SET GL=GC QUIT
 IF C="(" SET:'SV GC="(" SET GL=GC QUIT
 IF C=")" SET:'SV GC=")" SET GL=GC QUIT
 DO:VP
 . IF C="c" DO  QUIT
 . . SET:$GET(CP)="" CP=$LENGTH(CS)
 . . SET GC=$EXTRACT(CS,CP),CP=CP-1
 . . SET:CP<1 SP=$LENGTH(CS)
 . . QUIT
 . IF "fn+-"[C SET GC=$EXTRACT(V1,VP),VP=VP-1 QUIT
 . IF C="s" DO  QUIT
 . . SET:$GET(SP)="" SP=$LENGTH(SC)
 . . SET GC=$EXTRACT(SC,SP),SP=SP-1
 . . SET:SP<1 SP=$LENGTH(SC)
 . . QUIT
 . QUIT
 QUIT
 ;
 ; "c"    - Currency
 ; "f"    - Floating
 ; "n"    - Numeric
 ; "s"    - Separator
 ; "+-()" - Sign Representations
 ;
%TRANSV2 ; Translate the value into the mask
 SET GC=" "
 QUIT:"x "[C
 ;
 DO:VP
 . IF "f"[C DO  QUIT
 . . SET:$GET(CP)="" CP=1
 . . SET GC=$EXTRACT(CS,CP),CP=CP+1
 . . SET:CP>$LENGTH(CS) CP=1
 . . QUIT
 . IF C="n" DO  QUIT
 . . SET GC=$EXTRACT(V2,VP),VP=VP+1
 . . SET:VP>$LENGTH(V2) VP=0
 . . QUIT
 . IF C="s" DO  QUIT
 . . SET GC=$EXTRACT(SC,SP),SP=SP+1
 . . SET:SP<$LENGTH(SP) SP=1
 . . QUIT
 . QUIT
 IF "c"[C DO  QUIT
 . SET:$GET(CP)="" CP=1
 . SET GC=$EXTRACT(CS,CP)
 . SET:CP>$LENGTH(CS) GC=" "
 . SET CP=CP+1
 . QUIT
 IF C="+" SET GC="+" SET:'SV GC="-" SET GL=GC QUIT
 IF C="-" SET:'SV GC="-" SET GL=GC QUIT
 IF C="(" SET:'SV GC="(" SET GL=GC QUIT
 IF C=")" SET:'SV GC=")" SET GL=GC QUIT
 QUIT
 ;
%ERREX ; Error Exit point
 DO %ERROR
 QUIT K
 ;
 ; EC  - Error Coded String (1 character or longer)
 ; EL  - Error Code Length
 ; FL  - Field Length
 ; K   - Output String, The Error Message goes here.
%ERROR ; %ERROR HANDLING
 NEW C,E,EL,L
 SET:$GET(FL)<1 FL=$$%FLDLNG(0)
 SET E=$GET(EC),K="",L=1
 SET:E="" E="*"
 SET EL=$LENGTH(E)
 FOR I=1:1:FL SET C=$EXTRACT(E,L),L=L+1 SET:L>EL L=1 SET K=K_C
 QUIT
 ;
%LOADTV ; Do the translation of the temporary value with the string
 NEW X
 SET X=""
 FOR M=1:2:$LENGTH(TV,"%%") DO
 . SET X=X_$PIECE(TV,"%%",M)
 . SET N=$PIECE(TV,"%%",M+1)
 . SET:N X=X_ST(N)
 . QUIT
 SET TV=X
 QUIT
 ;
%FLDLNG(F) ; FIELD LENGTH Callable from Just About Anywhere
 SET F=$GET(F)
 QUIT:F F
 ;
 SET F=$LENGTH($GET(FO("FM")))
 IF 'F DO
 . SET F=$GET(FO("FL"))
 . IF 'F DO
 . . SET F=$LENGTH($GET(^$FORMAT("FM")))
 . . IF 'F DO
 . . . SET F=$GET(^$FORMAT("FL"))
 . . . IF 'F DO
 . . . . SET F=$LENGTH($GET(^$SYSTEM("FORMAT","FM")))
 . . . . IF 'F SET F=$GET(^$SYSTEM("FORMAT","FL"))
 . . . . QUIT
 . . . QUIT
 . . QUIT
 . QUIT 
 SET:'F F=10
 QUIT F
 ;
 ; Format Default Load
 ;
%INFORM ; Load up the defaults
 NEW K,X
 SET K="",X="FORMAT"
 IF '$DATA(^$FORMAT) DO  QUIT:$DATA(^$SYSTEM(X))
 . IF '$DATA(^$SYSTEM(X)) DO  QUIT
 . . SET ^$FORMAT("SC")=",",^$FORMAT("DC")="."
 . . SET ^$FORMAT("CS")="$",^$FORMAT("EC")="*"
 . . QUIT
 . MERGE ^$FORMAT=^$SYSTEM("FORMAT")
 . QUIT
 ; IF ^SYSTEM DOES NOT EXIST, CREATE IT
 DO:'$DATA(^$SYSTEM(X))
 . MERGE ^$SYSTEM("FORMAT")=^$FORMAT
 . QUIT
 QUIT
 ;
 ;===
 ;
 ;
CRC16(string,seed) ;
 ;
 ; The code below was approved in document X11/1998-32
 ;
 ; Polynomial x**16 + x**15 + x**2 + x**0
 NEW I,J,R
 IF '$DATA(seed) SET R=0
 ELSE  IF seed'<0,seed'>65535 SET R=seed\1
 ELSE  SET $ECODE=",M28,"
 FOR I=1:1:$LENGTH(string) DO
 . SET R=$$%XOR($ASCII(string,I),R,8)
 . FOR J=0:1:7 DO
 . . IF R#2 SET R=$$%XOR(R\2,40961,16)
 . . ELSE  SET R=R\2
 . . QUIT
 . QUIT
 QUIT R
%XOR(a,b,w) NEW I,M,R
 SET R=b,M=1
 FOR I=1:1:w DO
 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
 . SET M=M+M
 . QUIT
 QUIT R
 ;===
 ;
 ;
CRC32(string,seed) ;
 ;
 ; The code below was approved in document X11/1998-32
 ;
 ; Polynomial X**32 + X**26 + X**23 + X**22 +
 ;          + X**16 + X**12 + X**11 + X**10 +
 ;          + X**8  + X**7  + X**5  + X**4 +
 ;          + X**2  + X     + 1
 NEW I,J,R
 IF '$DATA(seed) SET R=4294967295
 ELSE  IF seed'<0,seed'>4294967295 SET R=seed\1
 ELSE  SET $ECODE=",M28,"
 FOR I=1:1:$LENGTH(string) DO
 . SET R=$$%XOR($ASCII(string,I),R,8)
 . FOR J=0:1:7 DO
 . . IF R#2 SET R=$$%XOR(R\2,3988292384,32)
 . . ELSE  SET R=R\2
 . . QUIT
 . QUIT
 QUIT 4294967295-R
 ; ===
 ;
 ;
CRCCCITT(string,seed) ;
 ;
 ; The code below was approved in document X11/1998-32
 ;
 ; Polynomial x**16 + x**12 + x**5 + x**0
 NEW I,J,R
 IF '$DATA(seed) SET R=65535
 ELSE  IF seed'<0,seed'>65535 SET R=seed\1
 ELSE  SET $ECODE=",M28,"
 FOR I=1:1:$LENGTH(string) DO
 . SET R=$$%XOR($ASCII(string,I)*256,R,16)
 . FOR J=0:1:7 DO
 . . SET R=R+R
 . . QUIT:R<65536
 . . SET R=$$%XOR(4129,R-65536,13)
 . . QUIT
 . QUIT
 QUIT R
 ; ===
 ;
 ;
LOWER(A,CHARMOD) NEW lo,up,x,y
 ;
 ; The code below was approved in document X11/1998-21
 ;
 SET x=$GET(CHARMOD)
 SET lo="abcdefghijklmnopqrstuvwxyz"
 SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 QUIT $TRANSLATE(A,up,lo)
 IF x?1"^"1E.E DO
 . SET x=$EXTRACT(x,2,$LENGTH(x))
 . IF x?1"|".E DO
 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
 . . SET x=$REVERSE($PIECE(x,"|",1))
 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
 . . QUIT
 . ELSE  SET x=$GET(^$GLOBAL(x,"CHARACTER"))
 . QUIT
 IF x="" SET x=^$JOB($JOB,"CHARACTER")
 SET x=$GET(^$CHARACTER(x,"LOWER"))
 IF x="" QUIT $TRANSLATE(A,up,lo)
 SET @("x="_x_"(A)")
 QUIT x
 ; ===
 ;
 ;
PATCODE(A,PAT,CHARMOD) NEW x,y
 ;
 ; The code below was approved in document X11/1998-21
 ;
 SET x=$GET(CHARMOD)
 IF x?1"^"1E.E DO
 . SET x=$EXTRACT(x,2,$LENGTH(x))
 . IF x?1"|".E DO
 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
 . . SET x=$REVERSE($PIECE(x,"|",1))
 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
 . . QUIT
 . ELSE  SET x=$GET(^$GLOBAL(x,"CHARACTER"))
 . QUIT
 IF x="" SET x=^$JOB($JOB,"CHARACTER")
 SET x=$GET(^$CHARACTER(x,"PATCODE",PAT))
 IF x="" QUIT 0
 SET @("x="_x_"(A)")
 QUIT x
 ; ===
 ;
 ;
UPPER(A,CHARMOD) NEW lo,up,x,y
 ;
 ; The code below was approved in document X11/1998-21
 ;
 SET x=$GET(CHARMOD)
 SET lo="abcdefghijklmnopqrstuvwxyz"
 SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 QUIT $TRANSLATE(A,lo,up)
 IF x?1"^"1E.E DO
 . SET x=$EXTRACT(x,2,$LENGTH(x))
 . IF x?1"|".E DO
 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
 . . SET x=$REVERSE($PIECE(x,"|",1))
 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
 . . QUIT
 . ELSE  SET x=$GET(^$GLOBAL(x,"CHARACTER"))
 . QUIT
 IF x="" SET x=^$JOB($JOB,"CHARACTER")
 SET x=$GET(^$CHARACTER(x,"UPPER"))
 IF x="" QUIT $TRANSLATE(A,lo,up)
 SET @("x="_x_"(A)")
 QUIT x
 ; ===
 ;
 ;


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>