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