home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database / CLIPR503.W96 / DBUSTRU.PR_ / DBUSTRU.PR
Text File  |  1995-06-26  |  27KB  |  1,347 lines
  1. /***
  2. *
  3. *  Dbustru.prg
  4. *
  5. *  DBU Create/Modify Structure Module
  6. *
  7. *  Copyright (c) 1990-1993, Computer Associates International, Inc.
  8. *  All rights reserved.
  9. *
  10. */
  11.  
  12.  
  13. ******
  14. *    modi_stru
  15. *
  16. *    create or modify the structure of a database file
  17. ******
  18. PROCEDURE modi_stru
  19. local saveColor
  20. PRIVATE filename,fill_row,cur_row,rec1,m_item,i,n,f_name,f_type,f_len,f_dec,;
  21.         prev_rec,field_id,stru_ok,is_insert,is_append,altered,type_n,;
  22.         empty_row,not_empty,old_help,chg_name,len_temp,stru_name,;
  23.         wstru_buff
  24.  
  25. * save help code
  26. old_help = help_code
  27. saveColor := SetColor(M->color7)
  28.  
  29. * allocate buffer and save window
  30. wstru_buff = SAVESCREEN(8, 20, 23, 59)
  31.  
  32. * local arrays..constant values
  33. DECLARE ffield[4]
  34. DECLARE field_col[4]
  35. DECLARE data_type[5]
  36. DECLARE l_usr[5]
  37.  
  38. * field list for structure file
  39. ffield[1] = "field_name"
  40. ffield[2] = "field_type"
  41. ffield[3] = "field_len"
  42. ffield[4] = "field_dec"
  43.  
  44. * display columns for ffield[]
  45. field_col[1] = 22
  46. field_col[2] = 35
  47. field_col[3] = 48
  48. field_col[4] = 55
  49.  
  50. * data types as character strings
  51. data_type[1] = "Character"
  52. data_type[2] = "Numeric  "
  53. data_type[3] = "Date     "
  54. data_type[4] = "Logical  "
  55. data_type[5] = "Memo     "
  56.  
  57. * last user definable ffield for each data type
  58. l_usr[1] = 3            && character - variable len
  59. l_usr[2] = 4            && numeric - variable len and dec
  60. l_usr[3] = 2            && date - fixed len - 8
  61. l_usr[4] = 2            && logical - fixed len - 1
  62. l_usr[5] = 2            && memo - fixed len - 10
  63.  
  64. * initialize local variables
  65. type_n = 1                && index into data types
  66. altered = .F.            && any changes?
  67. chg_name = .T.            && possible to change field names?
  68. prev_rec = 0            && detect record movement
  69. n = 1                    && current cursor column (1 - 4)
  70. i = 0                    && invalid field aspect
  71. cur_row = 13            && current cursor row
  72. is_insert = .F.            && .T. if insert new field
  73. keystroke = 999            && for initial screen fill
  74. filename = ""            && variable for "filebox" function
  75.  
  76. * sigle row templates
  77. empty_row = "           │           │       │    "
  78. not_empty = "           │ Character │    10 │    "
  79.  
  80. IF .NOT. EMPTY(M->cur_dbf)
  81.     * modify structure
  82.     stat_msg("Reading file structure")
  83.     stru_name = M->cur_dbf
  84.     SELECT (M->cur_area)
  85.  
  86.    // Attempt to re-open file exclusively if it's opened shared
  87.    IF NetMode()
  88.       IF !NetUse( M->cur_dbf, .T.,,, .T. )
  89.          ErrMsg( "Cannot modify the structure of " + M->cur_dbf + ;
  90.                  ":;Unable to obtain exclusive use" )
  91.          IF !NetUse( M->cur_dbf,,,, .T. )
  92.             clear_dbf(M->cur_area, 2)
  93.             cur_dbf = dbf[M->cur_area]
  94.          ENDIF
  95.          RETURN         /* NOTE */
  96.       ENDIF
  97.    ENDIF
  98.  
  99.     * create system structure extended file
  100.     COPY TO ddbbuuuu.ext STRUCTURE EXTENDED
  101.  
  102.     * open structure extended file in system reserved select area
  103.     SELECT 10
  104.     USE ddbbuuuu.ext
  105.  
  106.     * structure is valid and no new fields added
  107.     stru_ok = .T.
  108.     is_append = .F.
  109.  
  110.     * update screen header
  111.     stat_msg("")
  112.  
  113. ELSE
  114.     * create structure
  115.     SELECT 10
  116.     CREATE ddbbuuuu.ext
  117.  
  118.     * add first new field as yet undefined
  119.     APPEND BLANK
  120.     REPLACE field_type WITH "C",field_len WITH 10,field_dec WITH 0
  121.  
  122.     * structure is not valid
  123.     stru_ok = .F.
  124.     is_append = .T.
  125.     stru_name = ""
  126.  
  127. ENDIF
  128.  
  129. * clear and frame window
  130. scroll(8, 20, 23, 59, 0)
  131. @ 8, 20, 23, 59 BOX M->frame
  132.  
  133. * establish window heading
  134. @ 9,field_col[1];
  135. SAY "Structure of " + pad(IF(EMPTY(stru_name), "<new file>",;
  136.                             SUBSTR(stru_name, RAT("\", stru_name) + 1)), 13)
  137.  
  138. @ 11,22 SAY   "Field Name   Type        Width   Dec"
  139. @ 12,20 SAY "╞════════════╤═══════════╤═══════╤═════╡"
  140. @ 23,33 SAY              "╧═══════════╧═══════╧"
  141.  
  142. DO WHILE .NOT. q_check()
  143.     * the big switch
  144.  
  145.     DO CASE
  146.  
  147.         CASE keystroke = 999
  148.             * draw window
  149.             scroll(13, 21, 22, 58, 0)            && clear window
  150.             rec1 = RECNO()                        && first record in window
  151.             fill_row = 13                        && first row to fill
  152.  
  153.             DO WHILE .NOT. EOF() .AND. fill_row <= 22
  154.                 * fill the window
  155.                 stru_row(fill_row)
  156.  
  157.                 * next field/record number
  158.                 SKIP
  159.                 fill_row = fill_row + 1
  160.  
  161.             ENDDO
  162.  
  163.             DO WHILE fill_row <= 22
  164.                 * end of file..complete vertical bar lines
  165.                 @ fill_row,field_col[1] SAY empty_row
  166.                 fill_row = fill_row + 1
  167.  
  168.             ENDDO
  169.  
  170.             * adjust record pointer to current row
  171.             GOTO rec1
  172.             fill_row = 13
  173.  
  174.             DO WHILE fill_row < cur_row
  175.                 * move to same row if possible
  176.                 SKIP
  177.  
  178.                 IF EOF()
  179.                     * can't go all the way
  180.                     cur_row = fill_row
  181.                     GO BOTTOM
  182.                     EXIT
  183.  
  184.                 ENDIF
  185.  
  186.                 fill_row = fill_row + 1
  187.  
  188.             ENDDO
  189.  
  190.             keystroke = 0            && get new keystroke
  191.  
  192.         CASE keystroke = 13 .OR. isdata(keystroke)
  193.             * enter/select something
  194.  
  195.             IF n = 2
  196.                 * field_type gets special treatment
  197.                 type_n = AT(field_type, "CNDLM")
  198.  
  199.             ELSE
  200.                 * turn on cursor for GET
  201.                 SET CURSOR ON
  202.  
  203.                 IF keystroke <> 13
  204.                     * forward data character to GET system
  205.                     KEYBOARD CHR(keystroke)
  206.  
  207.                 ENDIF
  208.             ENDIF
  209.  
  210.             * get descriptor fieldname to normal variable for macro expansion
  211.             field_id = ffield[n]
  212.  
  213.             * save item to test for change
  214.             m_item = &field_id
  215.  
  216.             * set up and down arrows and menu keys to exit read
  217.             SET KEY 5 TO clear_gets
  218.             SET KEY 24 TO clear_gets
  219.             xkey_clear()
  220.  
  221.             DO CASE
  222.  
  223.                 CASE n = 1
  224.                     * get is for field_name..force all caps
  225.                     SetColor(M->color1)
  226.                     @ cur_row,field_col[1] GET field_name PICTURE "@!K"
  227.                     READ
  228.                     SetColor(M->color7)
  229.                     keystroke = LASTKEY()
  230.  
  231.                 CASE n = 2
  232.                     * special treatment for field_type
  233.  
  234.                     DO CASE
  235.  
  236.                         CASE UPPER(CHR(keystroke)) $ "CNDLM"
  237.                             * set field type to one of C, N, D, L, or M
  238.                             type_n = AT(UPPER(CHR(keystroke)), "CNDLM")
  239.                             keystroke = 13
  240.  
  241.                         CASE keystroke = 32
  242.                             * space bar..revolving field types
  243.                             type_n = IF(type_n = 5, 1, type_n + 1)
  244.  
  245.                         CASE keystroke <> 13
  246.                             * return key behaves like right arrow
  247.                             keystroke = 0
  248.  
  249.                     ENDCASE
  250.  
  251.                     IF m_item <> SUBSTR("CNDLM", type_n, 1)
  252.                         * set new field_type from type_n
  253.                         REPLACE field_type WITH SUBSTR("CNDLM", type_n, 1)
  254.  
  255.                         DO CASE
  256.                             * set field_len and field_dec according to type
  257.  
  258.                             CASE field_type = "C"
  259.                                 * character..any len will do, but not any dec
  260.                                 REPLACE field_dec WITH 0
  261.  
  262.                             CASE field_type = "N"
  263.                                 * numeric
  264.  
  265.                                 IF m_item = "C" .AND. (field_dec <> 0 .OR.;
  266.                                    field_len > 19)
  267.                                     * too long or Clipper extended len
  268.                                     REPLACE field_len WITH 10,field_dec WITH 0
  269.  
  270.                                 ENDIF
  271.  
  272.                             CASE field_type = "D"
  273.                                 * date..always 8
  274.                                 REPLACE field_len WITH 8,field_dec WITH 0
  275.  
  276.                             CASE field_type = "L"
  277.                                 * logical..always 1
  278.                                 REPLACE field_len WITH 1,field_dec WITH 0
  279.  
  280.                             CASE field_type = "M"
  281.                                 * memo..always 10
  282.                                 REPLACE field_len WITH 10,field_dec WITH 0
  283.  
  284.                         ENDCASE
  285.  
  286.                         * display new field_len
  287.                         @ cur_row,field_col[3] SAY STR(field_len,4)
  288.  
  289.                         IF field_type = "N"
  290.                             * display new field_dec
  291.                             @ cur_row,field_col[4] SAY field_dec
  292.  
  293.                         ELSE
  294.                             * ensure a blank field_dec column
  295.                             @ cur_row,field_col[4] SAY "   "
  296.  
  297.                         ENDIF
  298.                     ENDIF new type
  299.  
  300.                 CASE n = 3
  301.                     * get is for field_len
  302.  
  303.                     IF field_type = "C"
  304.                         * get Clipper extended field length into memvar
  305.                         len_temp = (256 * field_dec) + field_len
  306.  
  307.                     ELSE
  308.                         * normal field_len
  309.                         len_temp = field_len
  310.  
  311.                     ENDIF
  312.  
  313.                     * get the new length
  314.                     SetColor(M->color1)
  315.                     @ cur_row,field_col[n] GET len_temp PICTURE "9999"
  316.                     READ
  317.                     SetColor(M->color7)
  318.                     keystroke = LASTKEY()
  319.  
  320.                     IF menu_key() = 0
  321.                         * no menu request
  322.  
  323.                         IF field_type = "C"
  324.                             * put Clipper extended field length into len/dec
  325.                             REPLACE field_len WITH (len_temp % 256)
  326.                             REPLACE field_dec WITH INT(len_temp / 256)
  327.  
  328.                         ELSE
  329.  
  330.                             IF len_temp < 256
  331.                                 * may not be a valid length
  332.                                 REPLACE field_len WITH len_temp
  333.  
  334.                             ELSE
  335.                                 * entry not accepted
  336.                                 keystroke = 0
  337.  
  338.                             ENDIF
  339.                         ENDIF
  340.                     ENDIF
  341.  
  342.                 CASE n = 4
  343.                     * get is for field_dec
  344.                     SetColor(M->color1)
  345.                     @ cur_row,field_col[n] GET field_dec
  346.                     READ
  347.                     SetColor(M->color7)
  348.                     keystroke = LASTKEY()
  349.  
  350.             ENDCASE
  351.  
  352.             * release keys and wipe that cursor off the screen
  353.             SET KEY 5 TO
  354.             SET KEY 24 TO
  355.             xkey_norm()
  356.             SET CURSOR OFF
  357.  
  358.             IF menu_key() <> 0
  359.                 * restore the item and forward the menu key
  360.                 REPLACE &field_id WITH m_item
  361.                 KEYBOARD CHR(keystroke)
  362.  
  363.             ENDIF
  364.  
  365.             IF m_item <> &field_id
  366.                 * something has been changed
  367.                 stru_ok = .F.        && fieldspec may not be valid
  368.                 altered = .T.        && structure is altered
  369.  
  370.                 IF n > 1
  371.                     * can no longer change field names
  372.                     chg_name = .F.
  373.  
  374.                 ENDIF
  375.             ENDIF
  376.  
  377.             DO CASE
  378.  
  379.                 CASE keystroke = 18 .OR. keystroke = 5
  380.                     * up arrow or PgUp...move up
  381.                     keystroke = 5
  382.  
  383.                 CASE keystroke = 3 .OR. keystroke = 24
  384.                     * down arrow or PgDn...move down
  385.                     keystroke = 24
  386.  
  387.                 CASE keystroke = 13 .OR.;
  388.                      (isdata(keystroke) .AND. keystroke <> 32)
  389.                     * next field..space bar is used for revolving data types
  390.                     keystroke = 4
  391.  
  392.                 OTHERWISE
  393.                     * same field
  394.                     keystroke = 0
  395.  
  396.             ENDCASE
  397.  
  398.             * de-hilite the current item 
  399.             stru_item()
  400.  
  401.         CASE keystroke = 5 .AND. RECNO() > 1
  402.             * up arrow
  403.  
  404.             IF is_append
  405.                 * test newly appended field
  406.  
  407.                 IF .NOT. stru_ck(.F.)
  408.                     * delete newly appended field if exit up
  409.                     no_append()
  410.  
  411.                 ENDIF
  412.             ENDIF
  413.  
  414.             IF stru_ck(.T.)
  415.                 * move up one field
  416.                 SKIP -1
  417.  
  418.                 IF cur_row = 13
  419.                     * scroll required
  420.                     scroll(13, 21, 22, 58, -1)
  421.  
  422.                     * fill the blank row
  423.                     stru_row(13)
  424.  
  425.                 ELSE
  426.                     cur_row = cur_row - 1
  427.  
  428.                 ENDIF
  429.  
  430.                 is_append = .F.
  431.                 is_insert = .F.
  432.  
  433.             ELSE
  434.                 * fieldspec no good
  435.                 n = i
  436.  
  437.             ENDIF
  438.  
  439.             keystroke = 0
  440.  
  441.         CASE keystroke = 24
  442.             * down arrow
  443.  
  444.             IF stru_ck(RECNO() < LASTREC())
  445.                 * ok to move down one field
  446.                 SKIP
  447.  
  448.                 IF EOF()
  449.                     * down arrow will append
  450.                     APPEND BLANK
  451.                     REPLACE field_type WITH "C",field_len WITH 10,;
  452.                             field_dec WITH 0
  453.                     is_append = .T.
  454.                     stru_ok = .F.
  455.                     n = 1
  456.  
  457.                     IF cur_row < 22
  458.                         * show new field template
  459.                         @ cur_row + 1, field_col[1] SAY not_empty
  460.  
  461.                     ENDIF
  462.  
  463.                 ELSE
  464.                     is_insert = .F.
  465.  
  466.                 ENDIF
  467.  
  468.                 IF cur_row = 22
  469.                     * scroll required
  470.                     scroll(13, 21, 22, 58, 1)
  471.  
  472.                     * fill the blank row
  473.                     stru_row(22)
  474.  
  475.                 ELSE
  476.                     cur_row = cur_row + 1
  477.  
  478.                 ENDIF
  479.  
  480.             ELSE
  481.                 * fieldspec no good
  482.                 n = i
  483.  
  484.             ENDIF
  485.  
  486.             keystroke = 0
  487.  
  488.         CASE keystroke = 4
  489.             * right arrow
  490.  
  491.             IF n < l_usr[AT(field_type, "CNDLM")]
  492.                 n = n + 1
  493.  
  494.             ENDIF
  495.  
  496.             keystroke = 0
  497.  
  498.         CASE keystroke = 19
  499.             * left arrow
  500.  
  501.             IF n > 1
  502.                 n = n - 1
  503.  
  504.             ENDIF
  505.  
  506.             keystroke = 0
  507.  
  508.         CASE keystroke = 18
  509.             * PgUp
  510.             keystroke = 0
  511.  
  512.             IF RECNO() = 1
  513.                 * avoid re-draw if top of file
  514.                 LOOP
  515.  
  516.             ENDIF
  517.  
  518.             IF is_append
  519.                 * test newly appended field
  520.  
  521.                 IF .NOT. stru_ck(.F.)
  522.                     * delete newly appended field if exit up
  523.                     no_append()
  524.  
  525.                 ENDIF
  526.             ENDIF
  527.  
  528.             IF stru_ck(.T.)
  529.                 is_append = .F.
  530.                 is_insert = .F.
  531.  
  532.                 IF RECNO() = cur_row - 12
  533.                     * record 1 is on screen..no re-draw
  534.                     GO TOP
  535.                     cur_row = 13
  536.  
  537.                 ELSE
  538.                     * skip one page up and re-draw
  539.                     SKIP -(9 + cur_row - 13)
  540.                     keystroke = 999
  541.  
  542.                 ENDIF
  543.  
  544.             ELSE
  545.                 * fieldspec no good..no page up
  546.                 n = i
  547.  
  548.             ENDIF
  549.  
  550.         CASE keystroke = 3
  551.             * PgDn
  552.             keystroke = 0
  553.  
  554.             IF is_append
  555.                 * avoid error messages
  556.                 LOOP
  557.  
  558.             ENDIF
  559.  
  560.             IF stru_ck(.T.)
  561.                 is_insert = .F.
  562.  
  563.                 IF LASTREC() - RECNO() <= 22 - cur_row
  564.                     * last field is on screen
  565.                     cur_row = cur_row + LASTREC() - RECNO()
  566.                     GO BOTTOM
  567.  
  568.                 ELSE
  569.                     * skip one page down
  570.                     keystroke = 999            && cause re-draw of window
  571.                     SKIP 9 - (cur_row - 13)
  572.  
  573.                     IF EOF()
  574.                         * skip incomplete
  575.                         GO BOTTOM
  576.  
  577.                     ENDIF
  578.                 ENDIF
  579.  
  580.             ELSE
  581.                 * fieldspec no good
  582.                 n = i
  583.  
  584.             ENDIF
  585.  
  586.         CASE keystroke = 31
  587.             * ^PgUp..go to top of structure file
  588.             keystroke = 0
  589.  
  590.             IF RECNO() = 1
  591.                 * top of file
  592.                 LOOP
  593.  
  594.             ENDIF
  595.  
  596.             IF is_append
  597.                 * test newly appended field
  598.  
  599.                 IF .NOT. stru_ck(.F.)
  600.                     * delete newly appended field if exit up
  601.                     no_append()
  602.  
  603.                 ENDIF
  604.             ENDIF
  605.  
  606.             IF stru_ck(.T.)
  607.                 is_append = .F.
  608.                 is_insert = .F.
  609.  
  610.                 IF RECNO() > cur_row - 12
  611.                     * record 1 is not on screen
  612.                     keystroke = 999
  613.  
  614.                 ENDIF
  615.  
  616.                 GO TOP
  617.                 cur_row = 13
  618.  
  619.             ELSE
  620.                 * fieldspec no good
  621.                 n = i
  622.  
  623.             ENDIF
  624.  
  625.         CASE keystroke = 30
  626.             * ^PgDn
  627.             keystroke = 0
  628.  
  629.             IF is_append
  630.                 * avoid error messages
  631.                 LOOP
  632.  
  633.             ENDIF
  634.  
  635.             IF stru_ck(.T.)
  636.                 is_insert = .F.
  637.  
  638.                 IF LASTREC() - RECNO() <= 22 - cur_row
  639.                     * last field is on screen
  640.                     cur_row = cur_row + LASTREC() - RECNO()
  641.                     GO BOTTOM
  642.  
  643.                 ELSE
  644.                     * re-draw window with lastrec on last row
  645.                     keystroke = 999
  646.                     GO BOTTOM
  647.                     SKIP -9
  648.                     cur_row = 22
  649.  
  650.                 ENDIF
  651.  
  652.             ELSE
  653.                 * fieldspec no good
  654.                 n = i
  655.  
  656.             ENDIF
  657.  
  658.         CASE keystroke = 6 .OR. keystroke = 23
  659.             * end or ^end
  660.             keystroke = 0
  661.             n = l_usr[AT(field_type, "CNDLM")]
  662.  
  663.         CASE keystroke = 1 .OR. keystroke = 29
  664.             * home or ^home
  665.             keystroke = 0
  666.             n = 1
  667.  
  668.         CASE keystroke = 22
  669.             * insert a new field before cursor
  670.  
  671.             IF stru_ck(.T.)
  672.                 n = 1                    && cursor on field name
  673.                 stru_ok = .F.            && fieldspec not valid
  674.                 is_append = .F.            && not append
  675.                 is_insert = .T.            && new field inserted
  676.                 rec1 = RECNO()            && remember which field
  677.  
  678.                 * insert blank not available..do it the hard way
  679.                 APPEND BLANK
  680.  
  681.                 DO WHILE rec1 < RECNO()
  682.                     * shift up for insert
  683.                     SKIP -1
  684.  
  685.                     * get previous fieldspec
  686.                     f_name = field_name
  687.                     f_type = field_type
  688.                     f_len = field_len
  689.                     f_dec = field_dec
  690.  
  691.                     * put into current fieldspec
  692.                     SKIP
  693.                     REPLACE field_name WITH f_name,field_type WITH f_type,;
  694.                             field_len WITH f_len,field_dec WITH f_dec
  695.  
  696.                     * next
  697.                     SKIP -1
  698.  
  699.                 ENDDO
  700.  
  701.                 * make current fieldspec look like new
  702.                 REPLACE field_name WITH SPACE(10),field_type WITH "C",;
  703.                         field_len WITH 10,field_dec WITH 0
  704.  
  705.                 IF cur_row < 22
  706.                     * scroll down for insert
  707.                     scroll((cur_row), 21, 22, 58, -1)
  708.  
  709.                 ENDIF
  710.  
  711.                 * newly added field looks like this
  712.                 @ cur_row,field_col[1] SAY not_empty
  713.  
  714.             ELSE
  715.                 * fieldspec no good
  716.                 n = i
  717.  
  718.             ENDIF
  719.  
  720.             keystroke = 0
  721.  
  722.         CASE keystroke = 7 .AND. LASTREC() > 1
  723.             * delete..only the current record can be invalid
  724.             rec1 = RECNO()
  725.             DELETE
  726.             PACK
  727.  
  728.             IF rec1 > LASTREC()
  729.                 * last record has been deleted
  730.                 GO BOTTOM
  731.  
  732.                 IF cur_row = 13
  733.                     * top of window
  734.                     stru_row(13)
  735.  
  736.                 ELSE
  737.                     @ cur_row,field_col[1] SAY empty_row
  738.                     cur_row = cur_row - 1
  739.  
  740.                 ENDIF
  741.  
  742.             ELSE
  743.  
  744.                 IF cur_row < 22
  745.                     * scroll bottom part of window up
  746.                     scroll((cur_row), 21, 22, 58, 1)
  747.  
  748.                 ENDIF
  749.  
  750.                 * go to last field on screen
  751.                 GOTO rec1
  752.                 SKIP 22 - cur_row
  753.  
  754.                 IF .NOT. EOF()
  755.                     * fill bottom row
  756.                     stru_row(22)
  757.  
  758.                 ELSE
  759.                     * put blank template on last row
  760.                     @ 22,field_col[1] SAY empty_row
  761.  
  762.                 ENDIF
  763.  
  764.                 * move pointer to current record
  765.                 GOTO rec1
  766.  
  767.                 * same recno, but not the same record
  768.                 prev_rec = 0
  769.  
  770.             ENDIF
  771.  
  772.             IF .NOT. is_append .AND. .NOT. is_insert
  773.                 * structure is altered..cannot change names
  774.                 altered = .T.
  775.                 chg_name = .F.
  776.  
  777.             ENDIF
  778.  
  779.             * re-set tracking variables
  780.             is_append = .F.                && append is off
  781.             is_insert = .F.                && insert is off
  782.             stru_ok = .T.                && only current record can be invalid
  783.             keystroke = 0
  784.  
  785.         CASE prev_rec <> RECNO()
  786.             * record pointer has been moved and all cascading
  787.             *     keystrokes have been processed
  788.             prev_rec = RECNO()
  789.  
  790.             * update field/record number on screen
  791.             @ 9,field_col[1] + 26 SAY "Field " + pad(LTRIM(STR(RECNO())), 5)
  792.  
  793.             IF n > l_usr[AT(field_type, "CNDLM")]
  794.                 * check for n out of range
  795.                 n = l_usr[AT(field_type, "CNDLM")]
  796.  
  797.             ENDIF
  798.  
  799.         CASE local_func = 4
  800.             * "save structure" selected from pull down menu..keystroke = 0
  801.             local_func = 0
  802.  
  803.             IF .NOT. stru_ck(.T.)
  804.                 * fieldspec no good
  805.                 n = i
  806.                 LOOP
  807.  
  808.             ENDIF
  809.  
  810.             is_append = .F.
  811.             is_insert = .F.
  812.             filename = stru_name
  813.  
  814.             IF filebox(".DBF", "dbf_list", "stru_title",;
  815.                        "do_modstru", .T., 13) <> 0
  816.                 * structure created or altered
  817.                 stru_name = filename
  818.  
  819.                 * re-write name at top of window
  820.                 @ 9,field_col[1] + 13;
  821.                 SAY pad(IF(EMPTY(stru_name), "<new file>",;
  822.                             SUBSTR(stru_name, RAT("\", stru_name) + 1)), 13)
  823.  
  824.                 IF aseek(dbf, filename) = 0
  825.                     * bring new file into view
  826.                     cur_dbf = filename
  827.  
  828.                     open_dbf(.F., .T.)
  829.  
  830.                     * select system reserved work area
  831.                     SELECT 10
  832.  
  833.                 ENDIF
  834.  
  835.                 * exit to main View screen
  836.                 keystroke = 27    && exit this routine
  837.                 cur_area = 0    && re-draw View screen
  838.  
  839.             ENDIF
  840.  
  841.             * clear message from screen
  842.             stat_msg("")
  843.  
  844.         CASE local_func = 1
  845.             * "help" selected from pull down menu..keystroke = 0
  846.             local_func = 0
  847.             DO syshelp
  848.  
  849.         OTHERWISE
  850.             * get new keystroke
  851.  
  852.             IF .NOT. key_ready()
  853.                 * hi-lite the current item as reverse
  854.                 SetColor(M->color2)
  855.                 stru_item()
  856.                 SetColor(M->color7)
  857.  
  858.                 * wait for keystroke
  859.                 read_key()
  860.  
  861.                 IF .NOT. (keystroke = 13 .OR. isdata(keystroke))
  862.                     * this is not a GET..re-write as normal
  863.                     stru_item()
  864.  
  865.                 ENDIF
  866.             ENDIF
  867.  
  868.             IF keystroke = 27 .AND. altered
  869.                 * warning
  870.  
  871.                 IF rsvp("Ok To Lose Changes? (Y/N)") <> "Y"
  872.                     keystroke = 0
  873.  
  874.                 ENDIF
  875.             ENDIF
  876.     ENDCASE
  877. ENDDO create/modify structure
  878.  
  879. * close and erase structure file..all done
  880. USE
  881. ERASE ddbbuuuu.ext
  882.  
  883. * clear status line
  884. stat_msg("")
  885.  
  886. * restore window
  887. RESTSCREEN(8, 20, 23, 59, M->wstru_buff)
  888.  
  889. SetColor(saveColor)
  890. RETURN
  891.  
  892.  
  893. *******************
  894. * local functions *
  895. *******************
  896.  
  897. ******
  898. *    stru_row()
  899. *
  900. *    fill one row in structure window
  901. ******
  902. FUNCTION stru_row
  903.  
  904. PARAMETERS fill_row
  905.  
  906. @ fill_row,field_col[1];
  907. SAY field_name + " │ " + data_type[AT(field_type, "CNDLM")] + " │ "
  908.  
  909. IF field_type = "C"
  910.     * display Clipper extended field length
  911.     @ fill_row,field_col[3] SAY STR(((256 * field_dec) + field_len), 4) +;
  912.                                 " │    "
  913.  
  914. ELSE
  915.     * normal field length
  916.     @ fill_row,field_col[3] SAY STR(field_len, 4) + " │    "
  917.  
  918.     IF field_type = "N"
  919.         * display decimals for numeric field
  920.         @ fill_row,field_col[4] SAY field_dec
  921.  
  922.     ENDIF
  923. ENDIF
  924.  
  925. RETURN 0
  926.  
  927.  
  928. ******
  929. *    stru_item()
  930. *
  931. *    display item in structure window
  932. ******
  933. FUNCTION stru_item
  934.  
  935. DO CASE
  936.  
  937.     CASE n = 1
  938.         * field_name
  939.         @ cur_row,field_col[1] SAY field_name
  940.  
  941.     CASE n = 2
  942.         * display field_type as character string
  943.         @ cur_row,field_col[2] SAY data_type[AT(field_type, "CNDLM")]
  944.  
  945.     CASE n = 3
  946.  
  947.         IF field_type = "C"
  948.             * display Clipper extended field length
  949.             @ cur_row,field_col[n] SAY STR(((256 * field_dec) +;
  950.                                            field_len),4)
  951.  
  952.         ELSE
  953.             * normal field_len
  954.             @ cur_row,field_col[n] SAY STR(field_len,4)
  955.  
  956.         ENDIF
  957.  
  958.     CASE n = 4
  959.         * field_dec
  960.         @ cur_row,field_col[4] SAY field_dec
  961.  
  962. ENDCASE
  963.  
  964. RETURN 0
  965.  
  966.  
  967. ******
  968. *    no_append()
  969. *
  970. *    eliminate newly appended field/record
  971. ******
  972. FUNCTION no_append
  973.  
  974. DELETE
  975. PACK
  976. GO BOTTOM
  977. SKIP
  978.  
  979. IF (RECNO() = cur_row - 12) .OR. keystroke = 5
  980.     * blank the current row
  981.     @ cur_row,field_col[1] SAY empty_row
  982.  
  983. ENDIF
  984.  
  985. stru_ok = .T.
  986.  
  987. RETURN 0
  988.  
  989.  
  990. ******
  991. *    stru_ck()
  992. *
  993. *    test fieldspec if needed
  994. ******
  995. FUNCTION stru_ck
  996.  
  997. PARAMETERS disp_err
  998.  
  999. IF .NOT. stru_ok
  1000.     * fieldspec needs testing
  1001.     i = field_check(disp_err)
  1002.     stru_ok = (i = 0)
  1003.  
  1004. ENDIF
  1005.  
  1006. RETURN stru_ok
  1007.  
  1008.  
  1009. ******
  1010. *    field_check()
  1011. *
  1012. *    return number of invalid field aspect (field_name = 1, etc.), 0 if ok
  1013. ******
  1014. FUNCTION field_check
  1015.  
  1016. PARAMETERS disp_err
  1017. PRIVATE pos,test_num,test_name,status,err_msg
  1018.  
  1019. * initialize local variables
  1020. status = 0
  1021. err_msg = ""
  1022.  
  1023. * test for valid field name
  1024. pos = LEN(TRIM(field_name))
  1025.  
  1026. IF pos = 0
  1027.     * blank
  1028.     status = 1
  1029.     err_msg = "Blank Field Name"
  1030.  
  1031. ENDIF
  1032.  
  1033. IF status = 0
  1034.  
  1035.     DO WHILE pos > 0 .AND. SUBSTR(field_name, pos, 1) $;
  1036.                            "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"
  1037.         * validate all characters except trailing spaces
  1038.         pos = pos - 1
  1039.  
  1040.     ENDDO
  1041.  
  1042.     * the first character must be a letter
  1043.     IF pos > 0 .OR. SUBSTR(field_name, 1, 1) $ "0123456789_"
  1044.         * invalid character
  1045.         status = 1
  1046.         err_msg = "Illegal Field Name"
  1047.  
  1048.         IF keystroke = 24
  1049.             * force error display for illegal down arrow
  1050.             disp_err = .T.
  1051.  
  1052.         ENDIF
  1053.     ENDIF
  1054. ENDIF
  1055.  
  1056. IF status = 0
  1057.     * look for duplicate field name
  1058.     test_num = RECNO()
  1059.     test_name = field_name
  1060.     LOCATE FOR field_name = test_name .AND. RECNO() <> test_num
  1061.  
  1062.     IF FOUND()
  1063.         * duplicate field name
  1064.         status = 1
  1065.         err_msg = "Duplicate Field Name"
  1066.  
  1067.         IF keystroke = 24
  1068.             * force error display for illegal down arrow
  1069.             disp_err = .T.
  1070.  
  1071.         ENDIF
  1072.     ENDIF
  1073.  
  1074.     * re-set pointer to current record
  1075.     GOTO test_num
  1076.  
  1077. ENDIF
  1078.  
  1079. IF status = 0
  1080.     * test for valid field_len
  1081.  
  1082.     IF field_type = "C"
  1083.         test_num = (256 * field_dec) + field_len
  1084.  
  1085.         IF test_num <= 0 .OR. test_num > 1024
  1086.             * invalid field width
  1087.             status = 3
  1088.             err_msg = "Invalid Field Width"
  1089.  
  1090.             IF keystroke = 24
  1091.                 * force error display for illegal down arrow
  1092.                 disp_err = .T.
  1093.  
  1094.             ENDIF
  1095.         ENDIF
  1096.  
  1097.     ELSE
  1098.  
  1099.         IF field_len <= 0 .OR. field_len > 19
  1100.             * invalid field width
  1101.             status = 3
  1102.             err_msg = "Invalid Field Width"
  1103.  
  1104.             IF keystroke = 24
  1105.                 * force error display for illegal down arrow
  1106.                 disp_err = .T.
  1107.  
  1108.             ENDIF
  1109.         ENDIF
  1110.     ENDIF
  1111. ENDIF
  1112.  
  1113. IF field_type = "N" .AND. status = 0
  1114.     * test for valid field_dec
  1115.  
  1116.     IF field_dec > IF(field_len < 3, 0, IF(field_len > 17, 15, field_len - 2))
  1117.         * invalid decimal width
  1118.         status = 4
  1119.         err_msg = "Invalid Decimal Width"
  1120.  
  1121.         IF keystroke = 24
  1122.             * force error display for illegal down arrow
  1123.             disp_err = .T.
  1124.  
  1125.         ENDIF
  1126.     ENDIF
  1127. ENDIF
  1128.  
  1129. IF status > 0 .AND. disp_err
  1130.     * something not right that ought to be shown
  1131.     error_msg(err_msg)
  1132.  
  1133. ENDIF
  1134.  
  1135. RETURN status
  1136.  
  1137.  
  1138. *********************************
  1139. * functions called from filebox *
  1140. *********************************
  1141.  
  1142. ******
  1143. *    stru_title()
  1144. *
  1145. *    display title for save structure filebox
  1146. ******
  1147. FUNCTION stru_title
  1148.  
  1149. PARAMETERS sysparam
  1150.  
  1151. RETURN box_title(M->sysparam, "Save structure as...")
  1152.  
  1153.  
  1154. ******
  1155. *    do_modstru()
  1156. *
  1157. *    create/modify structure
  1158. ******
  1159. FUNCTION do_modstru
  1160.  
  1161. LOCAL cAlias
  1162. PRIVATE stru_done, i, is_open, new_name, name_temp, add_name,;
  1163.         dbt_spec, dbt_temp, rec1
  1164.  
  1165. DO CASE
  1166.  
  1167.     CASE EMPTY(filename)
  1168.         error_msg("File name not entered")
  1169.         stru_done = .F.
  1170.  
  1171.     OTHERWISE
  1172.         * determine if structure to be created is currently open
  1173.         i = aseek(dbf, filename)
  1174.         is_open = (i > 0)
  1175.  
  1176.         IF FILE(filename) .AND. .NOT. (filename == cur_dbf)
  1177.             * file exists and is not the current data file being modified
  1178.  
  1179.             IF rsvp(filename + IF(is_open, " Is Currently Open",;
  1180.                                            " Already Exists") +;
  1181.                     "...Overwrite? (Y/N)") <> "Y"
  1182.                 * oops
  1183.                 RETURN .F.
  1184.  
  1185.             ENDIF
  1186.         ENDIF
  1187.  
  1188.         IF is_open
  1189.             * can't really modify an open file, but we make it look that way
  1190.             name_temp = "ntx" + SUBSTR("123456", i, 1)
  1191.             need_ntx = need_ntx .OR. .NOT. EMPTY(&name_temp[1])
  1192.  
  1193.             * temporarily disable any relations targeted at the open file
  1194.             not_target(i, .F.)
  1195.  
  1196.             * close the file
  1197.             SELECT (M->i)
  1198.             USE
  1199.  
  1200.             name_temp = "kf" + SUBSTR("123456", i, 1)
  1201.  
  1202.             IF .NOT. EMPTY(&name_temp)
  1203.                 * will need to re-set the filter for the open file
  1204.                 need_filtr = .T.
  1205.  
  1206.             ENDIF
  1207.  
  1208.             * select system reserved work area
  1209.             SELECT 10
  1210.  
  1211.         ENDIF
  1212.  
  1213.         * remember the current field number and close structure file
  1214.         rec1 = RECNO()
  1215.         USE
  1216.  
  1217.         * remember if file existed in current directory before
  1218.         add_name = .NOT. FILE(name(filename) + ".DBF")
  1219.  
  1220.         IF FILE(filename)
  1221.             * file exists..modify structure and save old data
  1222.             new_name = " "
  1223.  
  1224.             IF chg_name .AND. altered
  1225.                 * rsvp change of field names
  1226.                 new_name = rsvp("Change Field Name(s)? (Y/N)")
  1227.  
  1228.                 IF .NOT. new_name $ "YN"
  1229.                     * Escape key will cancel the operation
  1230.                     USE ddbbuuuu.ext
  1231.                     GOTO rec1
  1232.                     RETURN .F.
  1233.  
  1234.                 ENDIF
  1235.             ENDIF
  1236.  
  1237.             * establish temp filespec and dbt specs in same directory
  1238.             name_temp = SUBSTR(filename, 1, RAT("\", filename)) +;
  1239.                         "DDBBUUUU.TMP"
  1240.             dbt_spec = SUBSTR(filename, 1, RAT(".", filename)) +;
  1241.                        "DBT"
  1242.             dbt_temp = SUBSTR(name_temp, 1, RAT(".", name_temp)) +;
  1243.                        "DBT"
  1244.  
  1245.             IF FILE(dbt_spec)
  1246.                 * data file contains memo fields
  1247.  
  1248.                 IF new_name = "Y"
  1249.                     * field_name change will lose memos during SDF copy
  1250.                     new_name = rsvp("Warning: Memos Will Be Lost" +;
  1251.                                     "...Proceed? (Y/N)")
  1252.  
  1253.                     IF new_name <> "Y"
  1254.                         * abort operation
  1255.                         USE ddbbuuuu.ext
  1256.                         GOTO rec1
  1257.                         RETURN .F.
  1258.  
  1259.                     ENDIF
  1260.                 ENDIF
  1261.  
  1262.                 * every dbt has its dbf
  1263.                 RENAME &dbt_spec TO &dbt_temp
  1264.  
  1265.             ENDIF
  1266.  
  1267.             stat_msg(IF(new_name <> "Y", "Altering file structure",;
  1268.                         "Changing field name(s)"))
  1269.  
  1270.             * save the old and create the new
  1271.             RENAME &filename TO &name_temp
  1272.          cAlias := MakeAlias( filename )
  1273.          CREATE &filename FROM ddbbuuuu.ext ALIAS cAlias
  1274.  
  1275.             IF new_name = "Y"
  1276.                 * change field names by copying SDF
  1277.                 USE &name_temp
  1278.                 COPY TO ddbbuuuu.txt SDF
  1279.                 USE &filename
  1280.                 APPEND FROM ddbbuuuu.txt SDF
  1281.                 ERASE ddbbuuuu.txt
  1282.  
  1283.             ELSE
  1284.                 * normal modify structure
  1285.                 APPEND FROM &name_temp
  1286.  
  1287.             ENDIF
  1288.  
  1289.             IF FILE(name_temp)
  1290.                 * delete temp file
  1291.                 ERASE &name_temp
  1292.  
  1293.             ENDIF
  1294.  
  1295.             IF FILE(dbt_temp)
  1296.                 * delete temp dbt file
  1297.                 ERASE &dbt_temp
  1298.  
  1299.             ENDIF
  1300.  
  1301.             IF is_open
  1302.                 * re-establish file in its original select area
  1303.                 USE                    && close in system reserved area
  1304.                 SELECT (M->i)        && select the correct area
  1305.                 USE &filename        && re-open the file
  1306.  
  1307.                 * establish new field list for new structure
  1308.                 name_temp = "field_n" + SUBSTR("123456", M->i, 1)
  1309.                 all_fields(M->i, &name_temp)
  1310.  
  1311.                 * re-select system reserved area
  1312.                 SELECT 10
  1313.  
  1314.             ENDIF
  1315.  
  1316.         ELSE
  1317.             * create new file
  1318.             stat_msg("Creating new data file")
  1319.          cAlias := MakeAlias( filename )
  1320.          CREATE &filename FROM ddbbuuuu.ext ALIAS cAlias
  1321.             USE
  1322.  
  1323.             IF AT(".DBF", filename) = LEN(filename) - 3 .AND.;
  1324.                FILE(name(filename) + ".DBF") .AND. add_name
  1325.                 * add only .dbf files in the current directory
  1326.                 i = afull(dbf_list) + 1
  1327.  
  1328.                 IF i <= LEN(dbf_list)
  1329.                     * add new file name to list
  1330.                     dbf_list[i] = filename
  1331.                     array_sort(dbf_list)
  1332.  
  1333.                 ENDIF
  1334.             ENDIF
  1335.         ENDIF
  1336.  
  1337.         * close newly created or modified file
  1338.         USE
  1339.         stru_done = .T.
  1340.  
  1341. ENDCASE
  1342.  
  1343. RETURN stru_done
  1344.  
  1345.  
  1346. * EOF DBUSTRU.PRG
  1347.