Merge branch '21-implement-xsmdel-in-xsm-file-api' into 'main'

Resolve "Implement xsmdel in XSM file API"

See merge request dragon/5.1!41

5 files changed, 82 insertions, 8 deletions

diff --git a/Ganlib/data/testgan2.x2m b/Ganlib/data/testgan2.x2m
index 4de50fa..c9ef50f 100644
--- a/Ganlib/data/testgan2.x2m
+++ b/Ganlib/data/testgan2.x2m
@@ -3,7 +3,8 @@
 *----
 LINKED_LIST TOTO FLUX MACRO GROUP ;
 SEQ_ASCII Macrolib FLUX2 ;
-MODULE DELETE: GREP: END: ;
+XSM_FILE FLUX3 ;
+MODULE DELETE: GREP: UTL: END: ;
 PROCEDURE TESTproc assertS ;
 REAL value ;
 *
@@ -13,10 +14,16 @@ GREP: GROUP :: GETVAL NTOT0 2 >>value<< ;
 ECHO "value=" value ;
 *
 FLUX2 := TESTproc MACRO :: 1.703945 ;
+FLUX3 := FLUX2 ;
 FLUX := FLUX2 :: EDIT 99 ;
 FLUX2 := DELETE: FLUX2 ;
 assertS FLUX :: 'K-EFFECTIVE' 1  1.703945 ;
 *
+UTL: FLUX3 :: DIR ;
+FLUX3 := UTL: FLUX3 :: DEL SIGNATURE ;
+FLUX3 := UTL: FLUX3 :: DEL DOUBLE-INFO ;
+UTL: FLUX3 :: DIR ;
+*
 ECHO "test TEST completed" ;
 END: ;
 QUIT "XREF" .
diff --git a/Ganlib/src/DRVUTL.f b/Ganlib/src/DRVUTL.f
index 36d171c..dc4a98d 100644
--- a/Ganlib/src/DRVUTL.f
+++ b/Ganlib/src/DRVUTL.f
@@ -417,10 +417,9 @@
 *       DELETE A BLOCK.
         IF(IND.EQ.2) CALL XABORT('DRVUTL: DEL IS A FORBIDDEN OPERATION'
      1  //' IN READ-ONLY MODE.')
-        IF(ITYPE.GT.1) CALL XABORT('DRVUTL: DEL CAN ONLY BE USED WITH '
-     1  //'LINKED-LISTS.')
         CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.')
+        IF(IMPX.GT.0) WRITE (6,170) NAMT
         CALL LCMDEL(IPLIST,NAMT)
       ELSE IF(TEXT4.EQ.'STAT') THEN
 *       COMPARE TWO BLOCKS STORED ON LCM OR XSM.
@@ -689,6 +688,7 @@
       ENDIF
       GO TO 10
 *
+  170 FORMAT (/17H DRVUTL: DELETE ',A12,2H'.)
   180 FORMAT (/36H DRVUTL: PERFORM UTILITY ACTIONS ON ,A11,9H OPEN IN ,
      1 A9,29H MODE WITH ACTIVE DIRECTORY ',A12,2H'./9X,9HLCM NAME=,A)
   190 FORMAT (/27H DRVUTL: STEP UP TO LEVEL ',A12,2H'.)
diff --git a/Ganlib/src/lcm_c.c b/Ganlib/src/lcm_c.c
index ee4a83a..7530cde 100644
--- a/Ganlib/src/lcm_c.c
+++ b/Ganlib/src/lcm_c.c
@@ -1666,9 +1666,8 @@ void lcmdel_c(lcm **iplist,const char *namp)
       xabort_c(AbortString);
    } else if ((*iplist)->header == 200) {
       /* USE A XSM FILE. */
-      sprintf(AbortString,"%s: UNABLE TO DELETE RECORD '%s' FROM AN XSM FILE.",
-              nomsub,(*iplist)->hname);
-      xabort_c(AbortString);
+      xsmdel_c((xsm **)iplist,namp);
+      return;
    } else if ((*iplist)->imode == 0) {
       sprintf(AbortString,"%s: THE OBJECT '%.60s' IS CLOSED.",
               nomsub,(*iplist)->hname);
diff --git a/Ganlib/src/xsm.h b/Ganlib/src/xsm.h
index 234dc1a..38110fc 100644
--- a/Ganlib/src/xsm.h
+++ b/Ganlib/src/xsm.h
@@ -65,6 +65,7 @@ typedef struct Db2{       /* xsmiof database handle */
 void xsmop_c(xsm **, char *, int_32, int_32);
 void xsmput_c(xsm **, const char *, int_32, int_32, int_32 *);
 void xsmget_c(xsm **, const char *, int_32 *);
+void xsmdel_c(xsm **, const char *);
 void xsmcl_c(xsm **, int_32);
 void xsmnxt_c(xsm **, char *);
 void xsmlen_c(xsm **, const char *, int_32 *, int_32 *);
diff --git a/Ganlib/src/xsm_c.c b/Ganlib/src/xsm_c.c
index 7abbf1f..1577fff 100644
--- a/Ganlib/src/xsm_c.c
+++ b/Ganlib/src/xsm_c.c
@@ -362,6 +362,9 @@ void xsmrep(const char *namt, int_32 *ind, int_32 *idir, block2 *my_block2, int_
    if (strcmp(namt,"***HANDLE***") == 0) {
       sprintf(AbortString,"%s: ***HANDLE*** IS A RESERVED KEYWORD.",nomsub);
       xabort_c(AbortString);
+   } else if (strcmp(namt,"***DEL***") == 0) {
+      sprintf(AbortString,"%s: ***DEL*** IS A RESERVED KEYWORD.",nomsub);
+      xabort_c(AbortString);
    }
    strcpy(namp,namt);
    if (strcmp(namp," ") == 0) strcpy(namp,"***HANDLE***");
@@ -496,6 +499,7 @@ void xsmput_c(xsm **iplist, const char *namp, int_32 ilong, int_32 itype, int_32
    }
    return;
 }
+
 void xsmget_c(xsm **iplist, const char *namp, int_32 *data2)
 /*
  *-----------------------------------------------------------------------
@@ -538,6 +542,47 @@ void xsmget_c(xsm **iplist, const char *namp, int_32 *data2)
    return;
 }
 
+void xsmdel_c(xsm **iplist, const char *namp)
+/*
+ *-----------------------------------------------------------------------
+ *
+ * delete a block in the xsm file.
+ *
+ * input parameter:
+ *  iplist : address of the handle to the xsm file.
+ *    namp : character*12 name of the current block.
+ *
+ *-----------------------------------------------------------------------
+ */
+{
+   char *nomsub="xsmdel_c";
+   char nomC[13] = "***DEL***";
+   block2 *my_block2;
+   int_32 iii;
+   if ((*iplist)->impf == 2) {
+      sprintf(AbortString,"%s: THE XSM FILE '%.60s' IS OPEN IN READ-ONLY MODE(1).",
+              nomsub,(*iplist)->hname);
+      xabort_c(AbortString);
+   } else if ((*iplist)->header != 200) {
+      sprintf(AbortString,"%s: THE XSM FILE '%.60s' HAVE THE WRONG HEADER.",
+              nomsub,(*iplist)->hname);
+      xabort_c(AbortString);
+   }
+   my_block2 = (*iplist)->ibloc;
+   xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii);
+   if (iii > 0) {
+      my_block2->modif = 1;
+      my_block2->jlon[iii - 1] = 0;
+      my_block2->jtyp[iii - 1] = 98;
+      strcpy(my_block2->cmt[iii - 1],nomC);
+   } else {
+      sprintf(AbortString,"%s: UNABLE TO FIND BLOCK '%s' INTO DIRECTORY '%s' IN THE XSM FILE '%.45s'.",
+              nomsub,namp,my_block2->mynam,(*iplist)->hname);
+      xabort_c(AbortString);
+   }
+   return;
+}
+
 void xsmcl_c(xsm **iplist, int_32 istatu)
 /*
  *-----------------------------------------------------------------------
@@ -682,9 +727,15 @@ void xsmnxt_c(xsm **iplist, char *namp)
    } else {
       xsmrep(namp, &c__1, &(*iplist)->idir, my_block2, &iii);
    }
+   int_32 icount=0;
+   L10: icount++;
+   if (icount >= 10000) {
+      sprintf(AbortString,"%s: PATHOLOGICAL CASE.",nomsub);
+      xabort_c(AbortString);
+   }
    if (iii == 0 && strcmp(namp, " ") == 0) {
 /*    EMPTY DIRECTORY */
-      sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY.",
+      sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY(1).",
               nomsub,my_block2->mynam,(*iplist)->hname);
       xabort_c(AbortString);
    } else if (iii == 0) {
@@ -693,6 +744,11 @@ void xsmnxt_c(xsm **iplist, char *namp)
       xabort_c(AbortString);
    } else if (iii + 1 <= my_block2->nmt) {
       strcpy(namp,my_block2->cmt[iii]);
+      if (strcmp(namp,"***DEL***") == 0) {
+         if (iii + 1 == my_block2->nmt) my_block2->nmt--;
+         iii++;
+         goto L10;
+      }
       return;
    }
 /* SWITCH TO THE NEXT DIRECTORY. */
@@ -702,8 +758,19 @@ void xsmnxt_c(xsm **iplist, char *namp)
 /*    RECOVER THE NEXT DIRECTORY. */
       xsmdir(&c__1, my_block2);
    }
-   strcpy(namp,my_block2->cmt[0]);
+   iii=0;
+   strcpy(namp,my_block2->cmt[iii]);
    if (strcmp(namp,"***HANDLE***") == 0) strcpy(namp," ");
+   if (strcmp(namp,"***DEL***") == 0) {
+      if (my_block2->nmt <= 1) {
+        sprintf(AbortString,"%s: THE ACTIVE DIRECTORY '%s' OF THE XSM FILE '%.45s' IS EMPTY(2).",
+                nomsub,my_block2->mynam,(*iplist)->hname);
+        xabort_c(AbortString);
+      }
+      if (iii + 1 == my_block2->nmt) my_block2->nmt--;
+      iii++;
+      goto L10;
+   }
    return;
 }