home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / SCHWARTZ.ZIP / EXAMPLE3.PRG < prev    next >
Encoding:
Text File  |  1990-06-06  |  7.6 KB  |  217 lines
  1. /*********************************************************************
  2. *
  3. * Name:        STRUCREC() - Extension UDF() to Clipper Debugger
  4. * Description:  Performs DISP STRUC and allows View/Edit of any record
  5. * Author:    Philip H. Schwartz
  6. * Audience:    Nantucket DEVCON '90
  7. * Written:      June 4, 1990
  8. * Compiler:    Clipper 5.0 V7.7 BETA
  9. * Comp Option:  /B
  10. * Linker:       RTLink Version 1.3 (Clipper)
  11. * Library:    clipper, extend
  12. * Obj Module:
  13. * Link input:   rtlink fi example3 out example3 li clipper,extend,cld 
  14. * Headers:    STD.ch
  15. * Copyright:    (c) 1990 Philip H. Schwartz
  16. * Rights:    All Commercial & Publishing Rights Reserved
  17. *
  18. *********************************************************************/
  19.  
  20. #include "achoice.ch"
  21. #include "inkey.ch"
  22.  
  23. #define DEMO                // remove this to compile UDF only
  24.  
  25. /* Defines for DBSTRUCT() array */
  26. #define    ARR_NAME            1
  27. #define    ARR_TYPE            2
  28. #define    ARR_LEN                3
  29. #define    ARR_DEC                4
  30.  
  31. /* Define for DIRECTRY() function */
  32. #define F_NAME                1
  33.  
  34. #ifdef DEMO
  35. /* The test program consists of the following line */
  36. WAIT                    // wait state to invoke debugger
  37. RETURN
  38. #endif
  39.  
  40. FUNCTION StrucRec
  41. LOCAL cFuncScreen,aStruct,aStruct2,aStruct3,aFlds,nChoice,cScreenSave,;
  42.  aFiles,aNames,cPicture,i
  43. PRIVATE nRecNum,nRelWindow
  44.  
  45. cFuncScreen=SAVESCREEN(0,0,24,79)    // save Debugger screen
  46. CLS
  47. aFiles:=DIRECTORY("*.dbf")        // creates nested array
  48.  
  49. /* Convert DIRECTORY() file name data to format that
  50.    can be used by ACHOICE, i.e. a single array of names.  We will
  51.    use the AEVAL array/codeblock function to do this.              */
  52. aNames:={}                
  53. AEVAL(aFiles, {|file| AADD(aNames,file[F_NAME])})
  54.  
  55. DO WHILE .t.
  56.  
  57.   cScreenSave=SAVESCREEN(1,0,10,14)    // save the ACHOICE screen area
  58.   @ 1,0 TO 10,14 DOUBLE            // draw ACHOICE frame
  59.   nChoice=ACHOICE(2,1,9,13,aNames)    // select one of the DBF files
  60.   RESTSCREEN(1,0,10,14,cScreenSave)    // restore the ACHOICE screen area
  61.  
  62.   IF nChoice=0                // check for ESC
  63.     EXIT                //  and EXIT
  64.   ENDIF                    //  the routine
  65.  
  66.   cFileName=TRIM(aNames[nChoice])    // pick up the file name
  67.   USE(cFileName) NEW            // open file in a new work area
  68.   aStruct:=DBSTRUCT()            // get structure information
  69.   aStruct2:=ARRAY(LEN(aStruct))        // make 2nd array
  70.  
  71.   /* Fill the 2nd array with formatted STRUC information */
  72.   FOR i=1 TO LEN(aStruct)
  73.     aStruct2[i]=STR(i,3)+" "+PAD(aStruct[i,ARR_NAME],10)+SPACE(1)+;
  74.      aStruct[i,ARR_TYPE]+SPACE(3)+STR(aStruct[i,ARR_LEN],2)+SPACE(1)+;
  75.      IIF(aStruct[i,ARR_TYPE]!="N",SPACE(2),STR(aStruct[i,ARR_DEC],2))
  76.   NEXT
  77.  
  78.   /* Use ACHOICE to display the formatted STRUC information for
  79.      this file.  We don't actually care what the user highlights.
  80.      We will however, check for ESC.                          */
  81.   cScreenSave=SAVESCREEN(1,0,10,30)    // save ACHOICE screen
  82.   @ 1,0 TO 10,30 DOUBLE            // draw the frame
  83.   nChoice=ACHOICE(2,1,9,29,aStruct2)    // allow user to scroll through struc
  84.   RESTSCREEN(1,0,10,30,cScreenSave)    // restore ACHOICE screen
  85.  
  86.   IF nChoice!=0 .AND. LASTREC()>0
  87.     aStruct3:=ARRAY(LEN(aStruct))    // make 3rd array for RECORD info
  88.     cScreenSave=SAVESCREEN(0,0,24,79)    // save ACHOICE screen
  89.     nRecNum=1                // start with RECNO()=1    
  90.  
  91.     @ 02,0 SAY REPLICATE(CHR(196),80)
  92.     @ 23,0 SAY REPLICATE(CHR(196),80)
  93.     @ 24,0 SAY 'Please make a selection: '+;
  94.      CHR(24)+CHR(25)+" "+CHR(26)+CHR(27)+" "+CHR(17)+CHR(196)+CHR(217)+;
  95.      ' PgUp PgDn Home End or ESC to Exit'
  96.     DO WHILE .t.
  97.       GOTO nRecNum            // go to selected RECNO()
  98.       @ 1,0                // blank out line
  99.       @ 1,0 SAY TRIM(cFileName)+"   Record # "+LTRIM(STR(nRecNum,6))+;
  100.        " of "+LTRIM(STR(LASTREC()))
  101.  
  102.       /* Fill the array with formatted RECORD information */
  103.       FOR i=1 TO LEN(aStruct)
  104.         aStruct3[i]=STR(i,3)+" "+PAD(aStruct[i,ARR_NAME],10)+":   "+;
  105.          ALLTRIM(FldFmt(aStruct[i,ARR_NAME]))
  106.       NEXT
  107.  
  108.       /* Let the user select a record to view or field to update */ 
  109.       nChoice=ACHOICE(3,0,22,79,aStruct3,,'user_rtn',nChoice)
  110.       DO CASE
  111.       /* If a field was selected for editing, check to see if it
  112.          is a numeric variable and create a PIC template for it */
  113.       CASE LASTKEY()=K_RETURN
  114.         IF aStruct[nchoice,ARR_TYPE]='N'
  115.           cPicture=REPLICATE("9",aStruct[nChoice,ARR_LEN])+;
  116.            IIF(aStruct[nChoice,ARR_DEC]=0,"","."+;
  117.            REPLICATE("9",aStruct[nChoice,ARR_DEC]))
  118.         ELSE
  119.           cPicture=NIL
  120.         ENDIF
  121.  
  122.         /* Update the field */
  123.         FldEdit(aStruct[nchoice,ARR_NAME],nchoice,cPicture)
  124.  
  125.       /* Check for ESC and exit */
  126.       CASE LASTKEY()=K_ESC
  127.         EXIT
  128.       ENDCASE
  129.     ENDDO
  130.     RESTSCREEN(0,0,24,79,cScreenSave)    // restore ACHOICE screen
  131.   ENDIF
  132. ENDDO
  133. RESTSCREEN(0,0,24,79,cFuncScreen)    // remember original screen    
  134. RETURN NIL
  135.  
  136. /* This function formats the fields of a DBF for display
  137.    based on the variable type */
  138. FUNCTION FldFmt
  139. PARAMETER FldName
  140. DO CASE
  141. CASE VALTYPE(&FldName)="C"
  142.   RETURN(PAD(&FldName,MIN(LEN(&FldName),80)))
  143. CASE VALTYPE(&FldName)="D"
  144.   RETURN(DTOC(&FldName))
  145. CASE VALTYPE(&FldName)="N"
  146.   RETURN(STR(&FldName))
  147. CASE VALTYPE(&FldName)="M"
  148.   RETURN("MEMO")
  149. CASE VALTYPE(&FldName)="L"
  150.   RETURN(IIF(&FldName,"TRUE","FALSE"))
  151. ENDCASE
  152. RETURN NIL
  153.  
  154. /* This function allows a user to edit any field in the
  155.    selected DBF.  Since the field count may have exceeded
  156.    the screen size and ACHOICE automatically scrolls array
  157.    elements, it is necessary to use the ACHOICE user function
  158.    to tell us the relative position in the window for the
  159.    selected element.  This value is stored in nRelWindow. */
  160. FUNCTION FldEdit
  161. PARAMETER cFldName,nElement,cPicture
  162. PRIVATE cMacFld
  163. cMacFld:=cFldName            // assign to PRIVATE for & GET
  164. SET DELIMITER OFF
  165. DO CASE
  166. CASE VALTYPE(&cMacFld)="C"
  167.   @ 3+nRelWindow,18 GET &cMacFld PICTURE '@k'
  168. CASE VALTYPE(&cMacFld)="D"
  169.   @ 3+nRelWindow,18 GET &cMacFld PICTURE '@d'
  170. CASE VALTYPE(&cMacFld)="N"
  171.   @ 3+nRelWindow,18 GET &cMacFld PICTURE(cPicture)
  172. CASE VALTYPE(&cMacFld)="L"
  173.   @ 3+nRelWindow,18 GET &cMacFld PICTURE 'L'
  174. ENDCASE
  175. READ
  176. RETURN NIL
  177.  
  178. /* This is the user function exit for the ACHOICE that we use
  179.    to inspect/edit individual records.  Its main function is to
  180.    keep track of the current element's relative position in the window.
  181.    It also is where we check for BOF(), EOF() and move the record
  182.    pointer up or down.                                                */
  183. FUNCTION user_rtn
  184. PARAMETER nMode,nCurElement,nRelPosition
  185. nRelWindow:=nRelPosition
  186. DO CASE
  187. CASE nMode=AC_IDLE            // check for IDLE state
  188.   RETURN(AC_CONT)            // yes, continue
  189. CASE nMode=AC_HITTOP .OR. ;        // check for -SKIP BOF() state
  190.  nMode=AC_HITBOTTOM            //  or SKIP EOF() state
  191.   TONE(500,1)                // beep
  192.   RETURN(AC_CONT)            //  and continue
  193. CASE nMode=AC_EXCEPT            // check for KEY EXCEPTION 
  194.   DO CASE
  195.   CASE LASTKEY()=K_LEFT            // check for left arrow
  196.     nRecNum=MAX(--nRecNum,1)        //  yes, previous record
  197.     RETURN(AC_SELECT)            //  and select
  198.   CASE LASTKEY()=K_RIGHT        // check for right arrow
  199.     nRecNum=MIN(++nRecNum,LASTREC())    //  yes, next record
  200.     RETURN(AC_SELECT)            //  and select
  201.   CASE LASTKEY()=K_RETURN        // check for RETURN
  202.     RETURN(AC_SELECT)            //  yes, select
  203.   CASE LASTKEY()=K_ESC            // check for ESC
  204.     RETURN(AC_ABORT)            //  yes, abort    
  205.   CASE LASTKEY()=K_HOME            // check for HOME
  206.     nRecNum=1                //  yes, GO TOP
  207.     RETURN(AC_SELECT)            //  and select
  208.   CASE LASTKEY()=K_END            // check for END
  209.     nRecNum=LASTREC()            //  yes, GO BOTTOM    
  210.     RETURN(AC_SELECT)            //  and select
  211.   ENDCASE  
  212. CASE nMode=AC_NOITEM            // check for NO ITEM state
  213.   RETURN(AC_CONT)            //  yes, continue
  214. ENDCASE
  215. RETURN(AC_CONT)
  216. /*EOF*/
  217.