home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database / CLIPR503.W96 / DBUUTIL.PR_ / DBUUTIL.PR
Text File  |  1995-06-26  |  44KB  |  2,312 lines
  1. /***
  2. *
  3. *  Dbuutil.prg
  4. *
  5. *  DBU Utilities Module
  6. *
  7. *  Copyright (c) 1990-1993, Computer Associates International, Inc.
  8. *  All rights reserved.
  9. *
  10. */
  11.  
  12.  
  13. ******
  14. *    setup()
  15. *
  16. *    put the current View into effect
  17. *
  18. *    note: - data files are open and closed at the time of
  19. *            selection, but everything else is done here
  20. *          - the global variables need_field, need_ntx,
  21. *            need_relat, and need_filtr prevent re-setting
  22. *            those portions of the View already in effect
  23. ******
  24. FUNCTION setup
  25.  
  26. PRIVATE k, t, n, i, j, field_n, s_alias, k_filter, ntx, file_name,;
  27.         k_1, k_2, k_3, k_4, k_5, k_6, k_7
  28.  
  29. stat_msg("Setting View")
  30.  
  31. IF M->need_field
  32.     * assemble master field list
  33.     need_field = .F.
  34.  
  35.     * get number of fields in old list
  36.     k = afull(M->field_list)
  37.  
  38.     n = 1
  39.     i = 1
  40.  
  41.     DO WHILE M->n <= 6 .AND. M->i <= LEN(M->field_list)
  42.  
  43.         IF EMPTY(dbf[M->n])
  44.             * no more active work areas
  45.             EXIT
  46.  
  47.         ENDIF
  48.  
  49.         * access one field list
  50.         field_n = "field_n" + SUBSTR("123456", M->n, 1)
  51.  
  52.         IF .NOT. EMPTY(&field_n[1])
  53.             * include "alias->" if work area > 1
  54.             s_alias = IF(M->n > 1, name(dbf[M->n]) + "->", "")
  55.             afill(M->field_list, M->s_alias, M->i, afull(&field_n))
  56.  
  57.             j = 1
  58.  
  59.             DO WHILE M->j <= LEN(&field_n) .AND. M->i <= LEN(M->field_list)
  60.  
  61.                 IF EMPTY(&field_n[M->j])
  62.                     * no more fields in list
  63.                     EXIT
  64.  
  65.                 ENDIF
  66.  
  67.                 * "alias->" + fieldname
  68.                 field_list[M->i] = field_list[M->i] + &field_n[M->j]
  69.  
  70.                 * next
  71.                 i = M->i + 1
  72.                 j = M->j + 1
  73.  
  74.             ENDDO
  75.         ENDIF
  76.  
  77.         * next work area
  78.         n = M->n + 1
  79.  
  80.     ENDDO
  81.  
  82.     IF M->i <= M->k
  83.         * clear fieldnames from longer previous list
  84.         afill(M->field_list, "", M->i)
  85.  
  86.     ENDIF
  87. ENDIF
  88.  
  89. IF M->need_ntx
  90.     * set all indexes
  91.     need_ntx = .F.
  92.  
  93.     n = 1
  94.  
  95.     DO WHILE M->n <= 6
  96.  
  97.         IF EMPTY(dbf[M->n])
  98.             * no more active work areas
  99.             EXIT
  100.  
  101.         ENDIF
  102.  
  103.         * access one index file list
  104.         ntx = "ntx" + SUBSTR("123456", M->n, 1)
  105.  
  106.         IF .NOT. EMPTY(&ntx[1])
  107.             * index(s) selected..set 7 variables to index file names
  108.             STORE "" TO k_1,k_2,k_3,k_4,k_5,k_6,k_7
  109.  
  110.             * select the proper work area
  111.             SELECT (M->n)
  112.  
  113.             i = 1
  114.  
  115.             DO WHILE M->i <= 7 .AND. EMPTY(M->view_err)
  116.                 * index files must exist
  117.  
  118.                 IF EMPTY(&ntx[M->i])
  119.                     * no more files in list
  120.                     EXIT
  121.  
  122.                 ENDIF
  123.  
  124.                 * save costly macro-array access
  125.                 file_name = &ntx[M->i]
  126.  
  127.                 IF FILE(M->file_name)
  128.                     * file exists..place filename in proper variable
  129.                     k = "k_" + SUBSTR("1234567", M->i, 1)
  130.                     &k = M->file_name
  131.                     i = M->i + 1
  132.  
  133.                 ELSE
  134.                     view_err = "Can't open index file " + M->file_name
  135.  
  136.                 ENDIF
  137.             ENDDO
  138.  
  139.             IF EMPTY(M->view_err)
  140.                 * null strings are acceptable between the commas
  141.                 SET INDEX TO &k_1,&k_2,&k_3,&k_4,&k_5,&k_6,&k_7
  142.  
  143.             ELSE
  144.                 * return with error message
  145.                 need_ntx = .T.
  146.                 RETURN 0
  147.  
  148.             ENDIF
  149.         ENDIF
  150.  
  151.         * next work area
  152.         n = M->n + 1
  153.  
  154.     ENDDO
  155. ENDIF
  156.  
  157. IF M->need_relat
  158.     * set all relations
  159.     need_relat = .F.
  160.  
  161.     * out with the old
  162.     FOR j = 1 TO 5
  163.         SELECT (M->j)
  164.         SET RELATION TO
  165.  
  166.     NEXT
  167.  
  168.     j = 1
  169.  
  170.     DO WHILE M->j <= LEN(M->k_relate)
  171.         * scan the entire active list
  172.  
  173.         IF EMPTY(k_relate[M->j])
  174.             * no more relations in list
  175.             EXIT
  176.  
  177.         ENDIF
  178.  
  179.         * select the source work area
  180.         n = ASC(s_relate[M->j]) - ASC("A") + 1
  181.         SELECT (M->n)
  182.  
  183.         * key and target to standard variables for macro expansion
  184.         k = k_relate[M->j]
  185.         t = SUBSTR(t_relate[M->j], 2)
  186.  
  187.         * this additive option is really nice
  188.         SET RELATION ADDITIVE TO &k INTO &t
  189.  
  190.         * next
  191.         j = M->j + 1
  192.  
  193.     ENDDO
  194.  
  195.     * align the entire chain of relations
  196.     SELECT 1
  197.     GO TOP
  198.  
  199. ENDIF
  200.  
  201. IF M->need_filtr
  202.     * set all filters
  203.     need_filtr = .F.
  204.  
  205.     n = 1
  206.  
  207.     DO WHILE M->n <= 6
  208.  
  209.         IF EMPTY(dbf[M->n])
  210.             * no more active work areas
  211.             EXIT
  212.  
  213.         ENDIF
  214.  
  215.         * access one global filter expression
  216.         k_filter = "kf" + SUBSTR("123456", M->n, 1)
  217.  
  218.         IF .NOT. EMPTY(&k_filter)
  219.             * set filter to global variable
  220.             SELECT (M->n)
  221.  
  222.             * expressions must remain in global variables
  223.             DO CASE
  224.  
  225.                 CASE M->n = 1
  226.                     SET FILTER TO &kf1
  227.  
  228.                 CASE M->n = 2
  229.                     SET FILTER TO &kf2
  230.  
  231.                 CASE M->n = 3
  232.                     SET FILTER TO &kf3
  233.  
  234.                 CASE M->n = 4
  235.                     SET FILTER TO &kf4
  236.  
  237.                 CASE M->n = 5
  238.                     SET FILTER TO &kf5
  239.  
  240.                 CASE M->n = 6
  241.                     SET FILTER TO &kf6
  242.  
  243.             ENDCASE
  244.  
  245.             * move pointer to first record that meets the condition
  246.             GO TOP
  247.  
  248.         ENDIF
  249.  
  250.         * next work area
  251.         n = M->n + 1
  252.  
  253.     ENDDO
  254. ENDIF
  255.  
  256. * clear message
  257. stat_msg("")
  258. RETURN 0
  259.  
  260.  
  261. **********************
  262. * multibox subsystem *
  263. **********************
  264.  
  265. ******
  266. *    multibox()
  267. *
  268. *    user entry/selection subsystem
  269. *
  270. *    sysparam values:
  271. *        1    =    initialize, display, and report position
  272. *        2    =    hilite (become the current item)
  273. *        3    =    dehilite (become a non-current item)
  274. *        4    =    become a selected item and return a new state
  275. *
  276. *    states:
  277. *        0    =    abort the process
  278. *        1    =    initialization
  279. *        2    =    pointing (cursor)
  280. *        3    =    entry/selection
  281. *        4    =    complete the process
  282. *
  283. *    note: - boxarray[] is an array of character strings that contain
  284. *            the names of functions with one predefined parameter like
  285. *            this: "function(sysparam)"
  286. *          - each function owns a screen coordinate which it must
  287. *            report during initialization
  288. *          - each higher element of boxarray[] must have its coordinate at
  289. *            the same or higher column (relative to the previous element)
  290. *            with no two elements having the same row/column combination
  291. ******
  292. FUNCTION multibox
  293.  
  294. PARAMETERS wt, wl, wh, beg_c, boxarray
  295. local saveColor
  296. PRIVATE sysparam, state, cursor, funcn, winbuff, save_help, prime_help,;
  297.         x, colorNorm, colorHilite
  298.  
  299. colorNorm := color8
  300. colorHilite := color10
  301.  
  302. * global variable eliminates recursive calls
  303. box_open = .T.
  304.  
  305. * help codes can be set freely within multibox subsystem
  306. save_help = M->help_code
  307. prime_help = M->help_code
  308.  
  309. * establish parallel arrays for row and column of each object
  310. DECLARE box_row[LEN(M->boxarray)]
  311. DECLARE box_col[LEN(M->boxarray)]
  312.  
  313. * save the window
  314. winbuff = SAVESCREEN(M->wt, M->wl, M->wt + M->wh + 1, M->wl + 45)
  315.  
  316. * clear and frame the window (fixed width, variable height and location)
  317. saveColor := SetColor(M->colorNorm)
  318. scroll(M->wt, M->wl, M->wt + M->wh + 1, M->wl + 45, 0)
  319. @ M->wt, M->wl, M->wt + M->wh + 1, M->wl + 45 BOX frame
  320.  
  321. * initialize, display, and report position
  322. sysparam = 1
  323.  
  324. FOR cursor = 1 TO LEN(M->boxarray)
  325.     * call all functions in list
  326.     funcn = boxarray[M->cursor]    && to normal variable for macro
  327.     x = &funcn                    && call the function
  328.     box_row[M->cursor] = ROW()    && save row coordinate
  329.     box_col[M->cursor] = COL()    && save col coordinate
  330.  
  331. NEXT
  332.  
  333. cursor = M->beg_c                && caller decides where to start
  334. state = 2                        && begin with pointing state
  335.  
  336. DO WHILE M->state <> 0 .AND. M->state <> 4
  337.     * loop until select or abort
  338.     funcn = boxarray[M->cursor]    && get current function from list
  339.  
  340.     DO CASE
  341.  
  342.         CASE M->state = 2
  343.             * pointing state
  344.  
  345.             IF .NOT. key_ready()
  346.                 * hilite
  347.                 sysparam = 2
  348.                 x = &funcn
  349.  
  350.                 * wait for key
  351.                 read_key()
  352.  
  353.             ENDIF
  354.  
  355.             DO CASE
  356.  
  357.                 CASE M->keystroke = 13 .OR. isdata(M->keystroke)
  358.                     * change to selection state
  359.                     state = 3
  360.  
  361.                 CASE M->local_func = 1
  362.                     * "help" selected from pull-down menu
  363.                     DO syshelp
  364.  
  365.                 CASE q_check()
  366.                     * process aborted
  367.                     state = 0
  368.  
  369.                 OTHERWISE
  370.                     * un-hilite
  371.                     sysparam = 3
  372.                     x = &funcn
  373.  
  374.                     * move cursor to new object
  375.                     cursor = matrix(M->cursor, M->keystroke)
  376.  
  377.             ENDCASE
  378.  
  379.         CASE M->state = 3
  380.             * selection state
  381.             sysparam = 4
  382.  
  383.             * all functions return a state value of 0, 2, or 4
  384.             state = &funcn
  385.  
  386.     ENDCASE
  387. ENDDO
  388.  
  389. * restore the window
  390. RESTSCREEN(M->wt, M->wl, M->wt + M->wh + 1, M->wl + 45, M->winbuff)
  391. SetColor(saveColor)
  392.  
  393. * reset global variables
  394. keystroke = 0                && not to get confused
  395. box_open = .F.                && box is closed
  396. help_code = M->save_help    && original help code
  397.  
  398. * a returned state of 0 means process aborted
  399. RETURN M->state
  400.  
  401.  
  402. ******
  403. *    matrix()
  404. *
  405. *    relocate cursor for multibox relative to current position
  406. *
  407. *    note: - the cursor value is a subscript into an array of function
  408. *            names passed to multibox (ex. boxarray[cursor])
  409. *          - each function owns a screen coordinate which is saved
  410. *            in the arrays box_row[] and box_col[]
  411. *          - since there is often a function that handles a list, the
  412. *            actual screen row is used to determine vertical position
  413. *          - since the actual cursor could be anywhere on that row, the
  414. *            reported column in box_col[] is used to determine horizontal
  415. *            position
  416. *          - the new cursor is a "best guess" move in one of four directions
  417. ******
  418. FUNCTION matrix
  419.  
  420. PARAMETERS old_curs, k
  421. PRIVATE old_row, old_col, test_curs, new_curs
  422.  
  423. * get current position
  424. old_row = ROW()                    && actual screen row is better for lists
  425. old_col = box_col[M->old_curs]    && col array..actual cursor could be anywhere
  426.  
  427. * new value same as old if no movement possible
  428. new_curs = M->old_curs
  429.  
  430. * beginning value for test probe
  431. test_curs = M->old_curs
  432.  
  433. DO CASE
  434.  
  435.     CASE M->k = 19 .OR. M->k = 219
  436.         * left arrow
  437.  
  438.         DO WHILE M->test_curs > 2
  439.             * test all lower elements except 1 which is always the title
  440.             test_curs = M->test_curs - 1
  441.  
  442.             IF box_col[M->test_curs] < M->old_col .AND.;
  443.                box_row[M->test_curs] >= M->old_row
  444.                 * never move up while moving left
  445.  
  446.                 IF box_row[M->test_curs] < box_row[M->new_curs];
  447.                    .OR. M->new_curs = M->old_curs
  448.                     * but no further down than we have to
  449.                     new_curs = M->test_curs
  450.  
  451.                 ENDIF
  452.             ENDIF
  453.         ENDDO
  454.  
  455.     CASE M->k = 4
  456.         * right arrow
  457.  
  458.         DO WHILE M->test_curs < LEN(M->box_col)
  459.             * test all higher elements
  460.             test_curs = M->test_curs + 1
  461.  
  462.             IF box_col[M->test_curs] > M->old_col .AND.;
  463.                box_row[M->test_curs] <= M->old_row
  464.                 * never move down while moving right
  465.  
  466.                 IF box_row[M->test_curs] > box_row[M->new_curs];
  467.                    .OR. M->new_curs = M->old_curs
  468.                     * but no further up than we have to
  469.                     new_curs = M->test_curs
  470.  
  471.                 ENDIF
  472.             ENDIF
  473.         ENDDO
  474.  
  475.     CASE M->k = 5
  476.         * up arrow
  477.  
  478.         DO WHILE M->test_curs > 2
  479.             * test all lower elements except 1 which is always the title
  480.             test_curs = M->test_curs - 1
  481.  
  482.             IF box_row[M->test_curs] < M->old_row .AND.;
  483.                box_col[M->test_curs] <= M->old_col
  484.                 * never move right while moving up
  485.  
  486.                 IF box_col[M->test_curs] > box_col[M->new_curs];
  487.                    .OR. M->new_curs = M->old_curs
  488.                     * but no further left than we have to
  489.                     new_curs = M->test_curs
  490.  
  491.                 ENDIF
  492.             ENDIF
  493.         ENDDO
  494.  
  495.     CASE M->k = 24
  496.         * down arrow
  497.  
  498.         DO WHILE M->test_curs < LEN(M->box_row)
  499.             * test all higher elements
  500.             test_curs = M->test_curs + 1
  501.  
  502.             IF box_row[M->test_curs] > M->old_row .AND.;
  503.                box_col[M->test_curs] >= M->old_col
  504.                 * never move left while moving down
  505.  
  506.                 IF box_col[M->test_curs] < box_col[M->new_curs];
  507.                    .OR. M->new_curs = M->old_curs
  508.                     * but no further right than we have to
  509.                     new_curs = M->test_curs
  510.  
  511.                 ENDIF
  512.             ENDIF
  513.         ENDDO
  514. ENDCASE
  515.  
  516. RETURN M->new_curs
  517.  
  518.  
  519. ******
  520. *    to_ok()
  521. *
  522. *    go directly to ok button
  523. *
  524. *    note: this routine depends upon things known and unknown
  525. ******
  526. FUNCTION to_ok
  527.  
  528. * set the cursor to the element before the ok button
  529. cursor = ascan(M->boxarray, "ok_button(sysparam)") - 1
  530.  
  531. * put a down arrow into the keyboard buffer
  532. KEYBOARD CHR(24)
  533.  
  534. RETURN 0
  535.  
  536.  
  537. ******
  538. *    to_can()
  539. *
  540. *    go directly to cancel button
  541. *
  542. *    note: this routine depends  p n th ngs kn wn  nd  nkn wn
  543. ******
  544. FUNCTION to_can
  545.  
  546. * set the cursor to the cancel button
  547. cursor = ascan(M->boxarray, "can_button(sysparam)")
  548.  
  549. * put a down arrow into the keyboard buffer
  550. KEYBOARD CHR(24)
  551.  
  552. RETURN 0
  553.  
  554.  
  555. ******
  556. *    ok_button
  557. *
  558. *    that's a wrap
  559. *
  560. *    note: - the caller of multibox must define the variable
  561. *            "okee_dokee" which contains a character string
  562. *            with the name of a function that takes no
  563. *            parameters (ex. "function()")
  564. *          - that function will either do whatever it is that
  565. *            multibox was called to do and return logical true,
  566. *            or return logical false meaning incomplete
  567. ******
  568. FUNCTION ok_button
  569.  
  570. PARAMETERS sysparam
  571. local saveColor
  572. PRIVATE ok, reply
  573.  
  574. * some boxes have secondary help
  575. help_code = M->prime_help
  576.  
  577. * initialize private variables
  578. ok = " Ok "        && some button eh?
  579. reply = 2        && assume incomplete
  580. saveColor := SetColor(M->colorNorm)
  581.  
  582. DO CASE
  583.  
  584.     CASE M->sysparam = 1 .OR. M->sysparam = 3
  585.         * initialize or un-hilite
  586.         @ M->wt + M->wh, M->wl + 8 SAY M->ok
  587.  
  588.         IF M->sysparam = 1
  589.             * report position
  590.             @ M->wt + M->wh, M->wl + 9 SAY ""
  591.  
  592.         ENDIF
  593.  
  594.     CASE M->sysparam = 2
  595.         * hilite
  596.         SetColor(M->colorHilite)
  597.         @ M->wt + M->wh, M->wl + 8 SAY M->ok
  598.  
  599.     CASE M->sysparam = 4 .AND. M->keystroke = 13
  600.         * selected, but only if enter key
  601.  
  602.         IF &okee_dokee
  603.             * process completed
  604.             reply = 4
  605.  
  606.         ENDIF
  607. ENDCASE
  608.  
  609. SetColor(saveColor)
  610. RETURN M->reply
  611.  
  612.  
  613. ******
  614. *    can_button()
  615. *
  616. *    note: pressing Escape has the same effect
  617. *          as selecting the cancel button
  618. ******
  619. FUNCTION can_button
  620.  
  621. PARAMETERS sysparam
  622. local saveColor
  623. PRIVATE can, reply
  624.  
  625. * some boxes have secondary help
  626. help_code = M->prime_help
  627.  
  628. * initialize private variables
  629. can = " Cancel "    && a button
  630. reply = 2            && assume incomplete
  631. saveColor := SetColor(M->colorNorm)
  632.  
  633. DO CASE
  634.  
  635.     CASE M->sysparam = 1 .OR. M->sysparam = 3
  636.         * initialize or un-hilite
  637.         @ M->wt + M->wh, M->wl + 17 SAY M->can
  638.  
  639.         IF M->sysparam = 1
  640.             * report position
  641.             @ M->wt + M->wh, M->wl + 17 SAY ""
  642.  
  643.         ENDIF
  644.  
  645.     CASE M->sysparam = 2
  646.         * hilite
  647.         saveColor := SetColor(M->colorHilite)
  648.         @ M->wt + M->wh, M->wl + 17 SAY M->can
  649.  
  650.     CASE M->sysparam = 4 .AND. M->keystroke = 13
  651.         * selected with the enter key..abort the process
  652.         reply = 0
  653.  
  654. ENDCASE
  655.  
  656. SetColor(saveColor)
  657. RETURN M->reply
  658.  
  659.  
  660. ******
  661. *    filelist()
  662. *
  663. *    select file from list
  664. ******
  665. FUNCTION filelist
  666.  
  667. PARAMETERS sysparam
  668.  
  669. RETURN itemlist(M->sysparam, 32, "filename", M->files, "*" + M->def_ext, .T.)
  670.  
  671.  
  672. ******
  673. *    fieldlist()
  674. *
  675. *    select field from list
  676. ******
  677. FUNCTION fieldlist
  678.  
  679. PARAMETERS sysparam
  680.  
  681. RETURN itemlist(M->sysparam, 34, "field_mvar", "field_m", "Fields", .F.)
  682.  
  683.  
  684. ******
  685. *    itemlist()
  686. *
  687. *    select item from list
  688. *
  689. *    note: - this list handler only responds to sysparam
  690. *            values of 1 (initialize) and 2 (hilite)
  691. *          - since both multibox() and achoice() wait for keystrokes,
  692. *            it is necessary to mediate for a smooth user interface
  693. *          - when sysparam = 2, achoice() is given control after
  694. *            which the select/abort status is resolved before
  695. *            returning control to multibox()
  696. ******
  697. FUNCTION itemlist
  698.  
  699. PARAMETERS sysparam, l_rel, mvar, items, i_title, go_ok
  700. local saveColor
  701. PRIVATE n, x, i_full
  702.  
  703. * some boxes have secondary help
  704. help_code = M->prime_help
  705. saveColor := SetColor(colorNorm)
  706.  
  707. * get size of list
  708. i_full = afull(&items)
  709.  
  710. DO CASE
  711.  
  712.     CASE M->sysparam = 1
  713.         * clear and frame the list portion of the box
  714.         scroll(M->wt + 1, M->wl + M->l_rel - 1, M->wt + M->wh, M->wl + 44, 0)
  715.         @ M->wt, M->wl + M->l_rel - 2, M->wt + M->wh + 1, M->wl + 45;
  716.         BOX M->lframe
  717.  
  718.         * format the list title
  719.         i_title = REPLICATE("─", ((46 - M->l_rel - LEN(M->i_title)) / 2) - 1);
  720.                   + " " + M->i_title + " "
  721.         i_title = M->i_title + REPLICATE("─", (46 - M->l_rel - LEN(M->i_title)))
  722.  
  723.         * display the list title
  724.         @ M->wt + 1, M->wl + M->l_rel - 1 SAY M->i_title
  725.  
  726.         IF .NOT. EMPTY(&items[1])
  727.             * display only..do not wait for keystrokes
  728.             achoice(M->wt + 2, M->wl + M->l_rel, M->wt + M->wh, M->wl + 43,;
  729.                     &items, .F., "i_func", M->cur_el, M->rel_row)
  730.  
  731.         ENDIF
  732.  
  733.         * report position
  734.         @ M->wt + 2, M->wl + M->l_rel SAY ""
  735.  
  736.     CASE M->sysparam = 2
  737.         * hilite
  738.  
  739.         IF EMPTY(&items[1])
  740.             * no list..go left
  741.             KEYBOARD(CHR(219))
  742.  
  743.         ELSE
  744.             * standard list selection..get starting element and row
  745.             cur_el = M->cur_el - M->rel_row + ROW() - M->wt - 2
  746.             rel_row = ROW() - M->wt - 2
  747.  
  748.             * get selected element or zero if abort
  749.             n = achoice(M->wt + 2, M->wl + M->l_rel, M->wt + M->wh,;
  750.                         M->wl + 43, &items, .T., "i_func", M->cur_el,;
  751.                         M->rel_row)
  752.  
  753.             * check for menu request
  754.             sysmenu()
  755.  
  756.             DO CASE
  757.  
  758.                 CASE M->keystroke = 13
  759.                     * item selected..place in variable
  760.                     &mvar = &items[M->n]
  761.  
  762.                     * call the specified function to display the selection
  763.                     x = &fi_disp
  764.  
  765.                     IF M->go_ok
  766.                         * go directly to the ok button for convenience
  767.                         to_ok()
  768.  
  769.                     ELSE
  770.                         * just move over and down
  771.                         KEYBOARD CHR(219) + CHR(24)
  772.  
  773.                     ENDIF
  774.  
  775.                 CASE M->keystroke = 19
  776.                     * left arrow..move off list by forwarding to multibox
  777.                     * cannot directly keyboard chr(19) because it would be
  778.                     *    handled like ^S and halt the system
  779.                     KEYBOARD CHR(219)
  780.  
  781.                 CASE M->keystroke = 0
  782.                     * menu system has returned either select or abort
  783.  
  784.                     IF M->local_func = 1
  785.                         * "help" selected from pull-down menu
  786.                         DO syshelp
  787.  
  788.                     ENDIF
  789.  
  790.                     * forward a "do nothing" keystroke to re-enter achoice
  791.                     KEYBOARD CHR(11)
  792.  
  793.                 OTHERWISE
  794.                     * let multibox() decide
  795.                     KEYBOARD CHR(M->keystroke)
  796.  
  797.             ENDCASE
  798.         ENDIF
  799. ENDCASE
  800.  
  801. SetColor(saveColor)
  802. RETURN 2
  803.  
  804.  
  805. ******
  806. *    i_func()
  807. *
  808. *    achoice user function for item list in multibox
  809. ******
  810. FUNCTION i_func
  811.  
  812. PARAMETERS amod, sel, rel
  813. PRIVATE r, srow, scol
  814.  
  815. * multibox looks at screen coordinates..must save
  816. srow = ROW()
  817. scol = COL()
  818.  
  819. IF M->error_on
  820.     * erase error message
  821.     error_off()
  822.  
  823. ENDIF
  824.  
  825. IF M->amod = 4
  826.     * nothing selectable
  827.     r = 0
  828.  
  829. ELSE
  830.     * maintain row and element variables
  831.     cur_el = M->sel
  832.     rel_row = M->rel
  833.  
  834.     * assume continue
  835.     r = 2
  836.  
  837.     * get latest keystroke
  838.     keystroke = LASTKEY()
  839.  
  840. ENDIF
  841.  
  842. IF M->cur_el > M->rel_row + 1
  843.     * first element not on screen
  844.     @ M->wt + 2, M->wl + 44 SAY M->more_up
  845.  
  846. ELSE
  847.     * first element is on screen
  848.     @ M->wt + 2, M->wl + 44 SAY " "
  849.  
  850. ENDIF
  851.  
  852. IF M->i_full - M->cur_el > M->wh - 2 - M->rel_row
  853.     * last element not on screen
  854.     @ M->wt + M->wh, M->wl + 44 SAY M->more_down
  855.  
  856. ELSE
  857.     * last element is on screen
  858.     @ M->wt + M->wh, M->wl + 44 SAY " "
  859.  
  860. ENDIF
  861.  
  862. IF M->amod = 3
  863.     * keystroke exception
  864.  
  865.     DO CASE
  866.  
  867.         CASE M->keystroke = 27
  868.             * escape..abort
  869.             r = 0
  870.  
  871.         CASE M->keystroke = 13 .OR. M->keystroke = 19 .OR. M->keystroke = 219
  872.             * quit achoice no abort..only the enter key will cause selection
  873.             r = 1
  874.  
  875.         CASE M->keystroke = 1
  876.             * home key..top of list
  877.             KEYBOARD CHR(31)    && ^PgUp
  878.  
  879.         CASE M->keystroke = 6
  880.             * end key..end of list
  881.             KEYBOARD CHR(30)    && ^PgDn
  882.  
  883.         CASE isdata(M->keystroke)
  884.             * request character search
  885.             r = 3
  886.  
  887.         CASE menu_key() <> 0
  888.             * abort to menu system
  889.             r = 0
  890.  
  891.     ENDCASE
  892. ENDIF
  893.  
  894. * restore screen coordinate
  895. @ M->srow, M->scol SAY ""
  896.  
  897. RETURN M->r
  898.  
  899.  
  900. ******
  901. *    getfile()
  902. *
  903. *    accept direct entry of filename in entry field
  904. *
  905. *    note: - the caller of multibox must establish the variables
  906. *            "filename", "def_ext", and "fi_done"
  907. *          - fi_done contains the name of a function that will
  908. *            decide if a filename is ready to be confirmed
  909. ******
  910. FUNCTION getfile
  911.  
  912. PARAMETERS sysparam, row_off
  913. local saveColor
  914. PRIVATE irow, name_temp
  915.  
  916. * some boxes have secondary help
  917. help_code = M->prime_help
  918.  
  919. * calculate absolute row
  920. irow = M->wt + M->row_off
  921. saveColor := SetColor(M->colorNorm)
  922.  
  923. DO CASE
  924.  
  925.     CASE M->sysparam = 1 .OR. M->sysparam = 3
  926.         * display
  927.         @ M->irow, M->wl + 2 SAY "File   " + pad(M->filename, 20)
  928.  
  929.         IF M->sysparam = 1
  930.             * report position
  931.             @ M->irow, M->wl + 9 SAY ""
  932.  
  933.         ENDIF
  934.  
  935.     CASE M->sysparam = 2
  936.         * hilite
  937.         SetColor(M->colorHilite)
  938.         @ M->irow, M->wl + 9 SAY pad(M->filename, 20)
  939.  
  940.     CASE M->sysparam = 4
  941.         * selected..accept input
  942.  
  943.         IF M->keystroke <> 13
  944.             * forward data keystroke to GET system
  945.             KEYBOARD CHR(M->keystroke)
  946.  
  947.         ENDIF
  948.  
  949.         * down arrow will exit READ
  950.         SET KEY 24 TO clear_gets
  951.  
  952.         * call entry in place function
  953.         name_temp = enter_rc(M->filename,M->irow,M->wl+9,64,"@K!S20",M->color9)
  954.  
  955.         * release down arrow
  956.         SET KEY 24 TO
  957.  
  958.         IF .NOT. EMPTY(M->name_temp)
  959.             * something entered
  960.  
  961.             IF .NOT. (RAT(".", M->name_temp) > RAT("\", M->name_temp))
  962.                 * extnesion not entered..provide default
  963.                 name_temp = M->name_temp + M->def_ext
  964.  
  965.             ENDIF
  966.  
  967.             * place in variable
  968.             filename = M->name_temp
  969.  
  970.         ELSE
  971.  
  972.             IF M->keystroke = 13 .OR. M->keystroke = 24
  973.                 * accept blank entry
  974.                 M->filename = ""
  975.  
  976.             ENDIF
  977.         ENDIF
  978.  
  979.         IF M->keystroke = 13
  980.             * entry is deliberate
  981.  
  982.             IF &fi_done
  983.                 * entry is acceptable
  984.                 @ M->irow, M->wl + 9 SAY pad(M->filename, 20)
  985.  
  986.             ENDIF
  987.  
  988.         ELSE
  989.  
  990.             IF M->keystroke <> 27 .AND. .NOT. isdata(M->keystroke)
  991.                 * something else..forward the keystroke to multibox
  992.                 KEYBOARD CHR(M->keystroke)
  993.  
  994.             ENDIF
  995.         ENDIF
  996. ENDCASE
  997.  
  998. SetColor(saveColor)
  999. RETURN 2
  1000.  
  1001.  
  1002. ******
  1003. *    g_getfile()
  1004. *
  1005. *    get filename for filebox function
  1006. ******
  1007. FUNCTION g_getfile
  1008.  
  1009. PARAMETERS sysparam
  1010.  
  1011. RETURN getfile(M->sysparam, 4)
  1012.  
  1013.  
  1014. ******
  1015. *    genfield()
  1016. *
  1017. *    process fieldname entry blank (called indirectly from multibox)
  1018. ******
  1019. FUNCTION genfield
  1020.  
  1021. PARAMETERS sysparam, is_replace
  1022.  
  1023. DO CASE
  1024.  
  1025.     CASE M->sysparam = 1 .OR. M->sysparam = 3
  1026.         * display
  1027.         @ M->wt + 3, M->wl + 2 SAY "Field  " + pad(M->field_mvar, 20)
  1028.  
  1029.         IF M->sysparam = 1
  1030.             * report position
  1031.             @ M->wt + 3, M->wl + 9 SAY ""
  1032.  
  1033.         ENDIF
  1034.  
  1035.     CASE M->sysparam = 2 .OR. M->sysparam = 4
  1036.         * no user entry allowed..deflect the cursor
  1037.  
  1038.         IF M->lkey = 5
  1039.             * upward movement..bounce right to list
  1040.             KEYBOARD CHR(4)
  1041.  
  1042.         ELSE
  1043.             * moving left from list..bounce down
  1044.  
  1045.             IF M->is_replace
  1046.                 * replace option..move down to expression
  1047.                 KEYBOARD CHR(24)
  1048.  
  1049.             ELSE
  1050.                 * getfield via set_view
  1051.  
  1052.                 IF EMPTY(M->field_mvar)
  1053.                     * nothing to select..go to Cancel
  1054.                     to_can()
  1055.  
  1056.                 ELSE
  1057.                     * go to Ok for confirmation
  1058.                     to_ok()
  1059.  
  1060.                 ENDIF
  1061.             ENDIF
  1062.         ENDIF
  1063. ENDCASE
  1064.  
  1065. RETURN 2
  1066.  
  1067.  
  1068. ******
  1069. *    get_exp()
  1070. *
  1071. *    accept input of a general dBASE expression
  1072. *
  1073. *    note: - the caller of multibox must establish the variable
  1074. *            whose name is in the "mvar" parameter
  1075. *          - this function is used for copy, append, replace, and create index
  1076. ******
  1077. FUNCTION get_exp
  1078.  
  1079. PARAMETERS sysparam, xlable, row_off, mvar
  1080. local saveColor
  1081. PRIVATE erow, k_input
  1082.  
  1083. * calculate absolute row
  1084. erow = M->wt + M->row_off
  1085. saveColor := SetColor(M->colorNorm)
  1086.  
  1087. DO CASE
  1088.  
  1089.     CASE M->sysparam = 1 .OR. M->sysparam = 3
  1090.         * display
  1091.         @ M->erow, M->wl + 2 SAY M->xlable + pad(&mvar, 20)
  1092.  
  1093.         IF M->sysparam = 1
  1094.             * report position
  1095.             @ M->erow, M->wl + 9 SAY ""
  1096.  
  1097.         ENDIF
  1098.  
  1099.     CASE M->sysparam = 2
  1100.         * hilite
  1101.         SetColor(M->colorHilite)
  1102.         @ M->erow, M->wl + 9 SAY pad(&mvar, 20)
  1103.  
  1104.     CASE M->sysparam = 4
  1105.         * selected..accept input
  1106.  
  1107.         IF M->keystroke <> 13
  1108.             * forward data keystroke to GET system
  1109.             KEYBOARD CHR(M->keystroke)
  1110.  
  1111.         ENDIF
  1112.  
  1113.         * up and down arrows will exit READ
  1114.         SET KEY 5 TO clear_gets
  1115.         SET KEY 24 TO clear_gets
  1116.  
  1117.         * call entry in place function
  1118.         k_input = enter_rc(&mvar, M->erow, M->wl + 9, 127, "@KS20", M->color9)
  1119.  
  1120.         * release up and down arrows
  1121.         SET KEY 5 TO
  1122.         SET KEY 24 TO
  1123.  
  1124.         IF .NOT. EMPTY(M->k_input)
  1125.             * something entered..place in variable
  1126.             &mvar = M->k_input
  1127.  
  1128.             IF M->keystroke <> 5 .AND. .NOT. isdata(M->keystroke)
  1129.                 * move down to next entry field
  1130.                 keystroke = 24
  1131.  
  1132.             ENDIF
  1133.  
  1134.         ELSE
  1135.  
  1136.             IF M->keystroke = 13 .OR. M->keystroke = 5 .OR. M->keystroke = 24
  1137.                 * accept blank entry
  1138.                 &mvar = ""
  1139.  
  1140.             ENDIF
  1141.         ENDIF
  1142.  
  1143.         IF M->keystroke <> 13 .AND. M->keystroke <> 27 .AND.;
  1144.            .NOT. isdata(M->keystroke)
  1145.             * something else..forward the keystroke to multibox
  1146.             KEYBOARD CHR(M->keystroke)
  1147.  
  1148.         ENDIF
  1149. ENDCASE
  1150.  
  1151. SetColor(saveColor)
  1152. RETURN 2
  1153.  
  1154.  
  1155. ******
  1156. *    not_empty()
  1157. *
  1158. *    general item entry preliminary test
  1159. ******
  1160. FUNCTION not_empty
  1161.  
  1162. PARAMETERS mvar
  1163. PRIVATE done_ok
  1164.  
  1165. * accept anything but a blank entry
  1166. done_ok = .NOT. EMPTY(&mvar)
  1167.  
  1168. IF M->done_ok
  1169.     * ready for confirmation
  1170.     to_ok()
  1171.  
  1172. ENDIF
  1173.  
  1174. RETURN M->done_ok
  1175.  
  1176.  
  1177. ******
  1178. *    filebox()
  1179. *
  1180. *    general file selection using multibox
  1181. ******
  1182. FUNCTION filebox
  1183.  
  1184. PARAMETERS def_ext, files, titl_func, do_func, creat_flag, box_top
  1185. PRIVATE rel_row, cur_el, fi_disp, okee_dokee, fi_done, bcur
  1186.  
  1187. * establish array for multibox
  1188. DECLARE boxarray[5]
  1189.  
  1190. boxarray[1] = M->titl_func + "(sysparam)"
  1191. boxarray[2] = "g_getfile(sysparam)"
  1192. boxarray[3] = "ok_button(sysparam)"
  1193. boxarray[4] = "can_button(sysparam)"
  1194. boxarray[5] = "filelist(sysparam)"
  1195.  
  1196. * initialize private variables
  1197. cur_el = 1
  1198. rel_row = 0
  1199. fi_disp = "g_getfile(3)"
  1200. fi_done = "not_empty('filename')"
  1201. okee_dokee = M->do_func + "()"
  1202.  
  1203. IF M->creat_flag
  1204.     * assume new filename to be entered
  1205.  
  1206.     IF EMPTY(filename)
  1207.         * beginning cursor on entry field
  1208.         bcur = 2
  1209.  
  1210.     ELSE
  1211.         * begin on ok button for fast confirmation
  1212.         bcur = 3
  1213.  
  1214.     ENDIF
  1215.  
  1216. ELSE
  1217.     * assume list selection preferred
  1218.     bcur = 5
  1219.  
  1220. ENDIF
  1221.  
  1222. * return same value as multibox
  1223. RETURN multibox(M->box_top, 17, 7, M->bcur, M->boxarray)
  1224.  
  1225.  
  1226. ******
  1227. *    box_title()
  1228. *
  1229. *    display the specified title for a selection box
  1230. ******
  1231. FUNCTION box_title
  1232.  
  1233. PARAMETERS sysparam, boxtitle
  1234.  
  1235. IF M->sysparam = 1
  1236.     @ M->wt + 1, M->wl + 2 SAY M->boxtitle
  1237.     @ M->wt + 1, M->wl + 2 SAY ""
  1238.  
  1239. ENDIF
  1240.  
  1241. RETURN 2
  1242.  
  1243.  
  1244. ******
  1245. *    get_k_trim()
  1246. *
  1247. *    accept character input to the pre-defined variable k_trim
  1248. *
  1249. *    note: this function is used for the "move" menu options
  1250. *          as well as entry of filter expressions
  1251. ******
  1252. FUNCTION get_k_trim
  1253.  
  1254. PARAMETERS sysparam, k_label
  1255. local saveColor
  1256. PRIVATE k_input
  1257.  
  1258. saveColor := SetColor(M->colorNorm)
  1259.  
  1260. DO CASE
  1261.  
  1262.     CASE M->sysparam = 1 .OR. M->sysparam = 3
  1263.         * display
  1264.         @ M->wt + 3, M->wl + 2 SAY pad(M->k_label, 12) + pad(M->k_trim, 30)
  1265.  
  1266.         IF M->sysparam = 1
  1267.             * report position
  1268.             @ M->wt + 3, M->wl + 9 SAY ""
  1269.  
  1270.         ENDIF
  1271.  
  1272.     CASE M->sysparam = 2
  1273.         * hilite
  1274.         SetColor(M->colorHilite)
  1275.         @ M->wt + 3, M->wl + 14 SAY pad(M->k_trim, 30)
  1276.  
  1277.     CASE M->sysparam = 4
  1278.         * selected..accept input
  1279.  
  1280.         IF M->keystroke <> 13
  1281.             * forward data keystroke to GET system
  1282.             KEYBOARD CHR(M->keystroke)
  1283.  
  1284.         ENDIF
  1285.  
  1286.         * down arrow will exit READ
  1287.         SET KEY 24 TO clear_gets
  1288.  
  1289.         * call entry in place function
  1290.         k_input = enter_rc(M->k_trim, M->wt + 3, M->wl + 14, 127, "@KS30",;
  1291.                            M->color9)
  1292.  
  1293.         * release down arrow
  1294.         SET KEY 24 TO
  1295.  
  1296.         IF .NOT. EMPTY(M->k_input)
  1297.             * something entered..place in variable
  1298.             k_trim = M->k_input
  1299.  
  1300.             * move to ok button
  1301.             keystroke = 24
  1302.  
  1303.         ELSE
  1304.  
  1305.             IF M->keystroke = 13 .OR. M->keystroke = 24
  1306.                 * accept blank entry
  1307.                 k_trim = ""
  1308.  
  1309.                 * move to ok button
  1310.                 keystroke = 24
  1311.  
  1312.             ENDIF
  1313.         ENDIF
  1314.  
  1315.         IF M->keystroke <> 13 .AND. M->keystroke <> 27 .AND.;
  1316.            .NOT. isdata(M->keystroke)
  1317.             * something else..forward the keystroke to multibox
  1318.             KEYBOARD CHR(M->keystroke)
  1319.  
  1320.         ENDIF
  1321. ENDCASE
  1322.  
  1323. SetColor(saveColor)
  1324. RETURN 2
  1325.  
  1326.  
  1327. *************************
  1328. * pull-down menu system *
  1329. *************************
  1330.  
  1331. ******
  1332. *    sysmenu()
  1333. *
  1334. *    administrate pull-down menu system
  1335. *
  1336. *    return: logical true if menu selection or keystroke available
  1337. *
  1338. *    note: - the menu titles are the same as the function key labels that
  1339. *            appear at the top of the screen
  1340. *          - these titles are stored in a global array called func_title[]
  1341. *          - for each title there is a corresponding pair of arrays whose
  1342. *            names are &a._m[] and &a._b[] where a = func_title[curr menu]
  1343. *          - the _m arrays contain the menu options and the _b arrays
  1344. *            determine the selectability of those options according to
  1345. *            the rules of the achoice() function
  1346. ******
  1347. FUNCTION sysmenu
  1348. local saveColor
  1349. PRIVATE menu_func,menu_sel,menu_buf,a,ml,mr,mb,prev_func,sav_row,sav_col,x
  1350.  
  1351. IF M->keystroke = 0
  1352.     * nothing happening
  1353.     RETURN .F.
  1354.  
  1355. ENDIF
  1356.  
  1357. * which menu?
  1358. menu_func = menu_key()
  1359.  
  1360. * always re-set this global selection variable
  1361. local_func = 0
  1362.  
  1363. IF M->menu_func = 0
  1364.     * no menu..regular keystroke
  1365.     RETURN .T.
  1366.  
  1367. ENDIF
  1368.  
  1369. ************************
  1370. * entering menu system *
  1371. ************************
  1372.  
  1373. * save screen coordinate
  1374. sav_row = ROW()
  1375. sav_col = COL()
  1376.  
  1377. IF M->error_on
  1378.     * erase error message
  1379.     error_off()
  1380.  
  1381. ENDIF
  1382.  
  1383. * initialize variables for selection process
  1384. menu_sel = 0
  1385. prev_func = 0
  1386. x = M->menu_func
  1387. saveColor := SetColor()
  1388.  
  1389. * abort or select
  1390. DO WHILE M->menu_func > 0 .AND. M->menu_sel = 0
  1391.     * avoid re-draw if menu already displayed
  1392.     IF M->menu_func <> M->prev_func
  1393.         * pull it on down
  1394.         lite_fkey(M->menu_func)                && hilite title
  1395.         prev_func = M->menu_func            && remember for next loop
  1396.         a = func_title[M->menu_func]        && get name of current menu
  1397.         ml = (10 * (M->menu_func - 1)) + 1    && calculate left coordinate
  1398.         mr = ((10 * M->menu_func) - 2)        && calculate right coordinate
  1399.         mb = (2 + LEN(&a._m))                && calculate bottom coordinate
  1400.  
  1401.         * save the window
  1402.         menu_buf = SAVESCREEN(2, M->ml - 1, M->mb + 1, M->mr + 1)
  1403.  
  1404.         * draw frame for current menu
  1405.         SetColor(M->color6)
  1406.         @ 2, M->ml - 1, M->mb + 1, M->mr + 1 BOX M->mframe
  1407.  
  1408.     ENDIF
  1409.  
  1410.     * call achoice() for selection
  1411.     SetColor(M->color5)
  1412.     menu_sel = achoice(3, M->ml, M->mb, M->mr, &a._m, &a._b, "mu_func",;
  1413.                        menu_deflt[M->menu_func], menu_deflt[M->menu_func] - 1)
  1414.  
  1415.     * see mu_func() below for setting of keystroke and x
  1416.     DO CASE
  1417.  
  1418.         CASE M->keystroke = 27
  1419.             * abort
  1420.             menu_func = 0
  1421.  
  1422.         CASE M->keystroke = 4
  1423.             * right arrow..next menu with wrap around
  1424.             menu_func = IF(M->menu_func < 8, M->menu_func + 1, 1)
  1425.  
  1426.         CASE M->keystroke = 19
  1427.             * left arrow..previous menu with wrap around
  1428.             menu_func = IF(M->menu_func > 1, M->menu_func - 1, 8)
  1429.  
  1430.         CASE M->x <> 0
  1431.             * directly to a different menu
  1432.             menu_func = M->x
  1433.  
  1434.     ENDCASE
  1435.  
  1436.     IF M->menu_func <> M->prev_func .OR. M->menu_sel <> 0
  1437.         * new menu or no menu..restore the screen
  1438.         dim_fkey(M->prev_func)
  1439.         RESTSCREEN(2, M->ml - 1, M->mb + 1, M->mr + 1, M->menu_buf)
  1440.  
  1441.     ENDIF
  1442. ENDDO
  1443.  
  1444. IF M->menu_func <> 0
  1445.     * most recently selected is the new default
  1446.     menu_deflt[M->menu_func] = M->menu_sel
  1447.  
  1448. ENDIF
  1449.  
  1450. IF LTRIM(STR(M->menu_func)) $ M->exit_str
  1451.     * selection requires a top level branch
  1452.     sysfunc = M->menu_func
  1453.     func_sel = M->menu_sel
  1454.  
  1455. ELSE
  1456.     * selection to be handled locally
  1457.     local_func = M->menu_func
  1458.     local_sel = M->menu_sel
  1459.  
  1460. ENDIF
  1461.  
  1462. * restore screen coordinate
  1463. @ M->sav_row,M->sav_col SAY ""
  1464.  
  1465. * not to be confused
  1466. keystroke = 0
  1467. SetColor(saveColor)
  1468.  
  1469. * return logical true if selection made
  1470. RETURN menu_func <> 0
  1471.  
  1472.  
  1473. ******
  1474. *    menu_key()
  1475. *
  1476. *    translate keystroke into menu number, zero if none
  1477. ******
  1478. FUNCTION menu_key
  1479.  
  1480. PRIVATE num
  1481.  
  1482. * assume no menu request
  1483. num = 0
  1484.  
  1485. DO CASE
  1486.  
  1487.     CASE M->keystroke = 28
  1488.         * F1
  1489.         num = 1
  1490.  
  1491.     CASE M->keystroke < 0 .AND. M->keystroke > -8
  1492.         * F2 - F8 (ex. 1 - (-1) = 2)
  1493.         num = 1 - M->keystroke
  1494.  
  1495.     CASE M->keystroke >= 249 .AND. M->keystroke < 256
  1496.         * F2 - F8..function keys get truncated by the chr() function
  1497.         *    (ex. chr(-1) = chr(255)..257 - 255 = 2)
  1498.         num = 257 - M->keystroke
  1499.  
  1500. ENDCASE
  1501.  
  1502. RETURN M->num
  1503.  
  1504.  
  1505. ******
  1506. *    mu_func()
  1507. *
  1508. *    achoice user function for pull-down menu system
  1509. ******
  1510. FUNCTION mu_func
  1511.  
  1512. PARAMETERS amod, sel, rel
  1513. PRIVATE r
  1514.  
  1515. IF M->amod = 4
  1516.     * none selectable..wait for keystroke
  1517.     keystroke = INKEY(0)
  1518.  
  1519.     * abort selection process
  1520.     r = 0
  1521.  
  1522. ELSE
  1523.     * get latest keystroke
  1524.     keystroke = LASTKEY()
  1525.  
  1526.     * assume continue selection process
  1527.     r = 2
  1528.  
  1529. ENDIF
  1530.  
  1531. * in case menu key pressed
  1532. x = menu_key()
  1533.  
  1534. IF M->amod = 3
  1535.     * keystroke exception
  1536.  
  1537.     DO CASE
  1538.  
  1539.         CASE M->keystroke = 13 .OR. M->x = M->menu_func
  1540.             * enter key or same function key..select
  1541.             r = 1
  1542.  
  1543.         CASE M->keystroke = 27 .OR. M->keystroke = 19 .OR.;
  1544.              M->keystroke = 4 .OR. M->x <> 0
  1545.             * different menu or no menu..abort from current menu
  1546.             r = 0
  1547.  
  1548.         CASE M->keystroke = 1
  1549.             * home key..top of list (^PgUp)
  1550.             KEYBOARD CHR(31)
  1551.  
  1552.         CASE M->keystroke = 6
  1553.             * end key..end of list (^PgDn)
  1554.             KEYBOARD CHR(30)
  1555.  
  1556.         CASE isdata(M->keystroke)
  1557.             * request character search
  1558.             r = 3
  1559.  
  1560.     ENDCASE
  1561. ENDIF
  1562.  
  1563. RETURN M->r
  1564.  
  1565.  
  1566. ******
  1567. *    show_keys()
  1568. *
  1569. *    display the available function menus
  1570. ******
  1571. FUNCTION show_keys
  1572.  
  1573. PRIVATE n
  1574.  
  1575. * clear the row
  1576. @ 1, 0
  1577.  
  1578. FOR n = 1 TO 8
  1579.     * display the function key titles
  1580.     @ 1,1 + (10 * (M->n - 1)) SAY func_title[M->n]
  1581.  
  1582. NEXT
  1583.  
  1584. RETURN 0
  1585.  
  1586.  
  1587. ******
  1588. *    xkey_clear()
  1589. *
  1590. *    cause all menu keys to clear gets and exit a read
  1591. ******
  1592. FUNCTION xkey_clear
  1593.  
  1594. PRIVATE i
  1595.  
  1596. * F1
  1597. SET KEY 28 TO clear_gets
  1598.  
  1599. FOR i = 1 TO 7
  1600.     * F2 - F8
  1601.     SET KEY -(M->i) TO clear_gets
  1602.  
  1603. NEXT
  1604.  
  1605. RETURN 0
  1606.  
  1607.  
  1608. ******
  1609. *    xkey_norm()
  1610. *
  1611. *    cause all menu keys to return to normal after xkey_clear
  1612. ******
  1613. FUNCTION xkey_norm
  1614.  
  1615. PRIVATE i
  1616.  
  1617. * F1
  1618. SET KEY 28 TO
  1619.  
  1620. FOR i = 1 TO 7
  1621.     * F2 - F8
  1622.     SET KEY -(M->i) TO
  1623.  
  1624. NEXT
  1625.  
  1626. RETURN 0
  1627.  
  1628.  
  1629. /*****
  1630. *    lite_fkey()
  1631. *
  1632. *    hilite the specified function key label
  1633. */
  1634. func lite_fkey(k_num)
  1635. local saveColor
  1636. memvar color6
  1637.  
  1638.     saveColor := SetColor(M->color11)
  1639.     @ 1, (10 * (k_num - 1)) say " " + func_title[k_num] + " "
  1640.     SetColor(saveColor)
  1641.  
  1642. return (0)
  1643.  
  1644.  
  1645. /*****
  1646. *    dim_fkey()
  1647. *
  1648. *    un-hilite the specified function key label
  1649. */
  1650. func dim_fkey(k_num)
  1651. local saveColor
  1652. memvar color1
  1653.  
  1654.     saveColor := SetColor(M->color1)
  1655.     @ 1, (10 * (k_num - 1)) say " " + func_title[k_num] + " "
  1656.     SetColor(saveColor)
  1657.  
  1658. return (0)
  1659.  
  1660.  
  1661. ******
  1662. *    key_ready()
  1663. *
  1664. *    return true if key ready or menu select
  1665. ******
  1666. FUNCTION key_ready
  1667.  
  1668. * save the previous keystroke
  1669. lkey = M->keystroke
  1670.  
  1671. * get new keystroke if ready
  1672. keystroke = INKEY()
  1673.  
  1674. RETURN (sysmenu() .OR. M->keystroke <> 0)
  1675.  
  1676.  
  1677. ******
  1678. *    read_key()
  1679. *
  1680. *    wait for keystroke or menu select
  1681. ******
  1682. FUNCTION read_key
  1683.  
  1684. DO WHILE .NOT. key_ready()
  1685.     * wait for keystroke or menu select
  1686.  
  1687. ENDDO
  1688.  
  1689. IF M->error_on
  1690.     * erase error message
  1691.     error_off()
  1692.  
  1693. ENDIF
  1694.  
  1695. RETURN M->keystroke
  1696.  
  1697.  
  1698. ******
  1699. *    raw_key()
  1700. *
  1701. *    wait for and return next key without checking for menu selection
  1702. ******
  1703. FUNCTION raw_key
  1704.  
  1705. PRIVATE k
  1706.  
  1707. * wait for key
  1708. k = INKEY(0)
  1709.  
  1710. IF M->error_on
  1711.     * erase error message
  1712.     error_off()
  1713.  
  1714. ENDIF
  1715.  
  1716. RETURN k
  1717.  
  1718.  
  1719. ******
  1720. *    q_check()
  1721. *
  1722. *    return true to cause exit from a routine
  1723. *
  1724. *    note: cur_func is set equal to sysfunc at the
  1725. *          top of the main loop of the program
  1726. ******
  1727. FUNCTION q_check
  1728.  
  1729. RETURN (M->cur_func <> M->sysfunc .OR. M->keystroke = 27)
  1730.  
  1731.  
  1732. ******
  1733. *    clear_gets
  1734. *
  1735. *    set keystrokes to this procedure to exit a READ
  1736. ******
  1737. PROCEDURE clear_gets
  1738. PARAMETERS dummy1,dummy2,dummy3
  1739.  
  1740. CLEAR GETS
  1741. RETURN
  1742.  
  1743.  
  1744. ******
  1745. *    all_fields()
  1746. *
  1747. *    fill field array with all fields for individual work area
  1748. ******
  1749. FUNCTION all_fields
  1750.  
  1751. PARAMETERS work_area,field_a
  1752.  
  1753. stat_msg("Reading file structure")
  1754.  
  1755. * will need to assemble master field list
  1756. need_field = .T.
  1757.  
  1758. * select the specified work area
  1759. SELECT (M->work_area)
  1760.  
  1761. * fill the array with field names..fill leftover elements with null strings
  1762. afill(M->field_a, "", afields(M->field_a) + 1)
  1763.  
  1764. * clear the status message and return
  1765. stat_msg("")
  1766. RETURN 0
  1767.  
  1768.  
  1769. ******
  1770. *    not_target()
  1771. *
  1772. *    remove relations where specified work area is target
  1773. ******
  1774. FUNCTION not_target
  1775.  
  1776. PARAMETERS n, do_del
  1777. PRIVATE i
  1778.  
  1779. i = 1
  1780.  
  1781. DO WHILE M->i <= LEN(M->k_relate)
  1782.     * search the entire list of relations
  1783.  
  1784.     IF EMPTY(k_relate[M->i])
  1785.         * end of list
  1786.         EXIT
  1787.  
  1788.     ENDIF
  1789.  
  1790.     IF t_relate[M->i] == CHR(M->n + ASC("A") - 1) + name(dbf[M->n])
  1791.         * alias is target of relation
  1792.         need_relat = .T.
  1793.  
  1794.         * select the source work area for this relation
  1795.         SELECT (M->n)
  1796.  
  1797.         * turn off the relation
  1798.         SET RELATION TO
  1799.  
  1800.         IF M->do_del
  1801.             * relation will not be re-set..remove from list
  1802.             array_del(M->s_relate,M->i)
  1803.             array_del(M->k_relate,M->i)
  1804.             array_del(M->t_relate,M->i)
  1805.  
  1806.         ELSE
  1807.             * next element
  1808.             i = M->i + 1
  1809.  
  1810.         ENDIF
  1811.  
  1812.     ELSE
  1813.         * alias is not target of relation..next element
  1814.         i = M->i + 1
  1815.  
  1816.     ENDIF
  1817. ENDDO
  1818.  
  1819. RETURN 0
  1820.  
  1821.  
  1822. ******
  1823. *    dup_ntx()
  1824. *
  1825. *    return work area where index is in use, zero if not found
  1826. ******
  1827. FUNCTION dup_ntx
  1828.  
  1829. PARAMETERS ntx_file
  1830. PRIVATE ntx, i
  1831.  
  1832. i = 1
  1833.  
  1834. DO WHILE M->i <= 6
  1835.  
  1836.     IF EMPTY(dbf[M->i])
  1837.         * no more active work areas
  1838.         EXIT
  1839.  
  1840.     ENDIF
  1841.  
  1842.     * access one index file list
  1843.     ntx = "ntx" + SUBSTR("123456", M->i, 1)
  1844.  
  1845.     IF aseek(&ntx, M->ntx_file) > 0
  1846.         * index file in use
  1847.         RETURN M->i
  1848.  
  1849.     ENDIF
  1850.  
  1851.     * next work area
  1852.     i = M->i + 1
  1853.  
  1854. ENDDO
  1855.  
  1856. RETURN 0
  1857.  
  1858.  
  1859. /*****
  1860. *    stat_msg()
  1861. *
  1862. *    display status message
  1863. */
  1864. func stat_msg(string)
  1865. local saveColor
  1866.  
  1867.     /* overwrite the entire row */
  1868.     saveColor := SetColor(M->color1)
  1869.     @ 3,0 say Pad(string,80)
  1870.     SetColor(saveColor)
  1871.  
  1872. return (0)
  1873.  
  1874.  
  1875. /*****
  1876. *    error_msg()
  1877. *
  1878. *    display error message and set global variable
  1879. *      to erase message with next keystroke
  1880. */
  1881. func error_msg(string)
  1882. local saveColor
  1883.  
  1884.     /* high intensity for error message */
  1885.     saveColor := SetColor(M->color3)
  1886.     @ 3,0 say string
  1887.  
  1888.     /* clear rest of message row */
  1889.     SetColor(M->color1)
  1890.     @ Row(), Col()
  1891.  
  1892.     /* next key stroke will erase message */
  1893.     error_on = .T.
  1894.     SetColor(saveColor)
  1895.  
  1896. return (0)
  1897.  
  1898.  
  1899. /*****
  1900. *    error_off()
  1901. *
  1902. *    erase error message
  1903. */
  1904. func error_off
  1905. local saveColor
  1906.  
  1907.     /* set global variable false */
  1908.     error_on = .F.
  1909.  
  1910.     /* clear the message row */
  1911.     saveColor := SetColor(M->color1)
  1912.     @ 3,0
  1913.     SetColor(saveColor)
  1914.  
  1915. return (0)
  1916.  
  1917.  
  1918. ******
  1919. *    rsvp()
  1920. *
  1921. *    get and return a Yes or No response (or Esc)
  1922. ******
  1923. FUNCTION rsvp
  1924.  
  1925. PARAMETERS string
  1926. PRIVATE c
  1927.  
  1928. * initialize local variable
  1929. c = " "
  1930.  
  1931. * Yes/No/Esc
  1932. DO WHILE .NOT. (M->c $ "YN" + CHR(27))
  1933.     * display message bright like error message
  1934.     error_msg(M->string + "  ")
  1935.  
  1936.     * place the cursor at the end of the message
  1937.     @ 3,LEN(M->string) + 1 SAY ""
  1938.  
  1939.     * make the cursor visible
  1940.     SET CURSOR ON
  1941.  
  1942.     * get the response and erase the message
  1943.     c = UPPER(CHR(raw_key()))
  1944.  
  1945.     IF .NOT. M->curs_on
  1946.         * get rid of the cursor
  1947.         SET CURSOR OFF
  1948.  
  1949.     ENDIF
  1950. ENDDO
  1951.  
  1952. RETURN M->c
  1953.  
  1954.  
  1955. ******
  1956. *    name()
  1957. *
  1958. *    extract filename from d:\path\filename.ext
  1959. ******
  1960. FUNCTION name
  1961.  
  1962. PARAMETERS spec
  1963. PRIVATE p
  1964.  
  1965. * isolate filename and extension from path
  1966. p = SUBSTR(M->spec, RAT("\", M->spec) + 1)
  1967.  
  1968. IF "." $ M->p
  1969.     * there is an extension..chop it off
  1970.     p = SUBSTR(M->p, 1, AT(".", M->p) - 1)
  1971.  
  1972. ENDIF
  1973.  
  1974. RETURN M->p
  1975.  
  1976.  
  1977. ******
  1978. *    pad()
  1979. *
  1980. *    force a string to a specified length
  1981. *
  1982. *    note: - if the string is longer than the specified
  1983. *            length it will be truncated
  1984. *          - if the string is shorter than the specified length
  1985. *            it will be padded with spaces on the right
  1986. ******
  1987. FUNCTION pad
  1988.  
  1989. PARAMETERS s, n
  1990.  
  1991. RETURN SUBSTR(M->s + SPACE(M->n), 1, M->n)
  1992.  
  1993.  
  1994. ******
  1995. *    aseek()
  1996. *
  1997. *    search for matching array element..return zero if not found
  1998. *
  1999. *    note: only non-empty elements are searched
  2000. ******
  2001. FUNCTION aseek
  2002.  
  2003. PARAMETERS array, exp
  2004. PRIVATE pos, num_el
  2005.  
  2006. * get number of non-empty elements
  2007. num_el = afull(M->array)
  2008.  
  2009. IF M->num_el = 0
  2010.     * not found if all empty
  2011.     RETURN 0
  2012.  
  2013. ENDIF
  2014.  
  2015. * perform exact search
  2016. SET EXACT ON
  2017.  
  2018. * ascan will return 0 if not found
  2019. pos = ascan(M->array, M->exp, 1, M->num_el)
  2020.  
  2021. * back to normal
  2022. SET EXACT OFF
  2023.  
  2024. RETURN M->pos
  2025.  
  2026.  
  2027. ******
  2028. *    array_ins()
  2029. *
  2030. *    shift elements up and set array[pos] = ""
  2031. *
  2032. *    note: the only difference between this function and the ains()
  2033. *          function is that here we set the inserted element to type C
  2034. ******
  2035. FUNCTION array_ins
  2036.  
  2037. PARAMETERS array, pos
  2038.  
  2039. * insert a new element
  2040. ains(M->array, M->pos)
  2041.  
  2042. * assign null string to new element
  2043. array[M->pos] = ""
  2044.  
  2045. RETURN 0
  2046.  
  2047.  
  2048. ******
  2049. *    array_del()
  2050. *
  2051. *    shift elements down and set array[len(array)] = ""
  2052. *
  2053. *    note: the only difference between this function and the adel()
  2054. *          function is that here we set the last element to type C
  2055. ******
  2056. FUNCTION array_del
  2057.  
  2058. PARAMETERS array, pos
  2059.  
  2060. * delete the specified element
  2061. adel(M->array, M->pos)
  2062.  
  2063. * assign null string to last element
  2064. array[LEN(M->array)] = ""
  2065.  
  2066. RETURN 0
  2067.  
  2068.  
  2069. ******
  2070. *    afull()
  2071. *
  2072. *    find the number of contiguous full elements before the first null string
  2073. ******
  2074. FUNCTION afull
  2075.  
  2076. PARAMETERS array
  2077. PRIVATE i
  2078.  
  2079. * perform exact search
  2080. SET EXACT ON
  2081.  
  2082. * search for null string
  2083. i = ascan(M->array, "")
  2084.  
  2085. * back to normal
  2086. SET EXACT OFF
  2087.  
  2088. IF M->i = 0
  2089.     * no null strings means completely full
  2090.     i = LEN(M->array)
  2091.  
  2092. ELSE
  2093.     * element of first null string - 1
  2094.     i = M->i - 1
  2095.  
  2096. ENDIF
  2097.  
  2098. RETURN M->i
  2099.  
  2100.  
  2101. ******
  2102. *    array_sort()
  2103. *
  2104. *    sort the contiguous full elements before the first null string
  2105. ******
  2106. FUNCTION array_sort
  2107.  
  2108. PARAMETERS array
  2109.  
  2110. * sort only the full elements
  2111. asort(M->array, 1, afull(M->array))
  2112.  
  2113. RETURN 0
  2114.  
  2115.  
  2116. ******
  2117. *    array_dir()
  2118. *
  2119. *    prepare a sorted array of filenames that match a skeleton
  2120. ******
  2121. FUNCTION array_dir
  2122.  
  2123. PARAMETERS skeleton, array
  2124.  
  2125. * begin with an empty array
  2126. afill(M->array, "")
  2127.  
  2128. * fill the array with filenames
  2129. adir(M->skeleton, M->array)
  2130.  
  2131. * sort the array
  2132. array_sort(M->array)
  2133.  
  2134. RETURN 0
  2135.  
  2136.  
  2137. ******
  2138. *    ntx_key(filename)
  2139. *
  2140. *    read the key from an index file
  2141. *
  2142. *    note: this function assumes a valid index file
  2143. ******
  2144. FUNCTION ntx_key
  2145.  
  2146. PARAMETERS filename
  2147. PRIVATE k, buffer, handle, k_pos
  2148.  
  2149. * initialize variable to hold key expression
  2150. k = ""
  2151.  
  2152. IF FILE(M->filename)
  2153.     * only if the file exists
  2154.  
  2155.     IF INDEXEXT() = ".NTX"
  2156.         * Clipper index file format
  2157.         k_pos = 23
  2158.  
  2159.     ELSE
  2160.         * .NDX..dBASE index file format
  2161.         k_pos = 25
  2162.  
  2163.     ENDIF
  2164.  
  2165.     * open the file and get handle
  2166.     handle = FOPEN(M->filename)
  2167.  
  2168.     IF FERROR() = 0
  2169.         * allocate 512 byte buffer
  2170.         buffer = SPACE(512)
  2171.  
  2172.         * read the index file header into memory
  2173.         FREAD(M->handle, @buffer, 512)
  2174.  
  2175.         * discard all bytes before the key expression
  2176.         k = SUBSTR(M->buffer, M->k_pos)
  2177.  
  2178.         * the expression is terminated with a zero byte (chr(0))
  2179.         k = TRIM(SUBSTR(M->k, 1, AT(CHR(0), M->k) - 1))
  2180.  
  2181.     ENDIF
  2182.  
  2183.     * close the file and release the handle
  2184.     FCLOSE(M->handle)
  2185.  
  2186. ENDIF
  2187.  
  2188. RETURN M->k
  2189.  
  2190.  
  2191. ******
  2192. *    isdata()
  2193. *
  2194. *    determine if a key is data suitable for entry in place
  2195. ******
  2196. FUNCTION isdata
  2197.  
  2198. PARAMETERS k
  2199.  
  2200. RETURN (M->k >= 32 .AND. M->k < 249 .AND. M->k <> 219 .AND. CHR(M->k) <> ";")
  2201.  
  2202.  
  2203. ******
  2204. *    lpad()
  2205. *
  2206. *    pad with spaces on the left
  2207. *
  2208. *    note: this routine will fail if the requested len() is
  2209. *          less than len(string)
  2210. ******
  2211. FUNCTION lpad
  2212.  
  2213. PARAMETERS string,n
  2214.  
  2215. RETURN (SPACE(M->n - LEN(M->string)) + M->string)
  2216.  
  2217.  
  2218. ******
  2219. *    hi_cur()
  2220. *
  2221. *    hilite the current data file
  2222. ******
  2223. FUNCTION hi_cur
  2224. local saveColor
  2225.  
  2226. IF M->cur_area > 0
  2227.     * write on the main View screen
  2228.     saveColor := SetColor(M->color2)
  2229.     @ row_a[1], column[M->cur_area] + 2 SAY pad(name(M->cur_dbf), 8)
  2230.     SetColor(saveColor)
  2231.  
  2232. ENDIF
  2233.  
  2234. RETURN 0
  2235.  
  2236.  
  2237. ******
  2238. *    dehi_cur()
  2239. *
  2240. *    display the current data file to un-hilite
  2241. ******
  2242. FUNCTION dehi_cur
  2243. local saveColor
  2244.  
  2245. IF M->cur_area > 0
  2246.     * write on the main View screen
  2247.     saveColor := SetColor(M->color1)
  2248.     @ row_a[1], column[M->cur_area] + 2 SAY pad(name(M->cur_dbf), 8)
  2249.     SetColor(saveColor)
  2250.  
  2251. ENDIF
  2252.  
  2253. RETURN 0
  2254.  
  2255.  
  2256. ******
  2257. *    enter_rc()
  2258. *
  2259. *    entry in place
  2260. ******
  2261. FUNCTION enter_rc
  2262.  
  2263. PARAMETERS org_str, r, c, max_len, pfunc, cString
  2264. local saveColor
  2265. PRIVATE wk_str
  2266.  
  2267. * set menu keys to exit READ
  2268. xkey_clear()
  2269.  
  2270. * set initial work string from original string
  2271. wk_str = pad(M->org_str, M->max_len)
  2272. SET CURSOR ON
  2273. saveColor := SetColor(M->cString)
  2274.  
  2275. IF .NOT. EMPTY(M->pfunc)
  2276.     * perform GET with picture clause
  2277.     @ r, c GET M->wk_str PICTURE M->pfunc
  2278.  
  2279. ELSE
  2280.     * no picture clause
  2281.     @ r, c GET M->wk_str
  2282.  
  2283. ENDIF
  2284.  
  2285. * accept data input
  2286. READ
  2287. SET CURSOR OFF
  2288.  
  2289. * set global variable to exit key
  2290. keystroke = LASTKEY()
  2291.  
  2292. * release menu keys
  2293. xkey_norm()
  2294.  
  2295. IF M->error_on
  2296.     * erase error message
  2297.     error_off()
  2298.  
  2299. ENDIF
  2300.  
  2301. IF M->keystroke = 27 .OR. menu_key() <> 0
  2302.     * aborted entry..return null string
  2303.     wk_str = ""
  2304.  
  2305. ENDIF
  2306.  
  2307. SetColor(saveColor)
  2308. RETURN TRIM(M->wk_str)
  2309.  
  2310.  
  2311. * EOF DBUUTIL.PRG
  2312.