Liren Large Software Subsidy 5

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 5 / 05.iso / a / a009 / 6.ddi / DBU.LIF / DBUVIEW.PRG < prev

Wrap

Text File | 1991-04-14 | 65.7 KB | 3,264 lines

************ * * Program....: DBU * Filename...: DBUVIEW.PRG * Author.....: Dennis L. Dias * Date.......: 06/18/86, 06/18/90 * Purpose....: View Maintenance Module * * Copyright (c) 1986-1990 Nantucket Corp., All Rights Reserved. * ************ ****** * set_view * * select files, set fields, relations, filters * * note: only data files are opened and closed when * requested..all other aspects of the View are * set when needed by calling the setup() function * in the utilities module ****** PROCEDURE set_view local saveColor PRIVATE bar_line,empty_line,ntx,field_n,el,cur_row,t_row,ch_draw,; strn,is_redraw,is_insert,horiz_keys,prev_area,i saveColor := SetColor(M->color1) * establish local array for index file names (no path or extension) DECLARE d_array[LEN(M->ntx1)] * initialize local variables horiz_keys = CHR(4) + CHR(19) + CHR(1) + CHR(6) && quick return from bar_menu bar_line = "" && built by bline() empty_line = "" && ditto prev_area = 0 && detect horizontal movement (zero to initialize) ch_draw = .F. && switch for channel function * global help code help_code = 1 * global key value..zero is convenient for branch to "otherwise" case below keystroke = 0 * special attention for open and create menu defaults set_deflt() IF .NOT. EMPTY(M->view_err) * with soap it's loaded error_msg(M->view_err) view_err = "" ENDIF DO WHILE .NOT. q_check() * one big switch..exit condition determined elsewhere DO CASE CASE M->cur_area = 0 * draw View screen..see if complete reset needed cur_area = aseek(M->dbf, M->cur_dbf) IF M->cur_area = 0 * complete reset needed FOR i = 1 TO 3 * current rows and current elements STORE row_a[M->i] TO cr1[M->i],cr2[M->i],cr3[M->i],; cr4[M->i],cr5[M->i],cr6[M->i] STORE 1 TO el1[M->i],el2[M->i],el3[M->i],el4[M->i],; el5[M->i],el6[M->i] NEXT * global variables cur_dbf = dbf[1] STORE 1 TO cur_area, page * set default for open and create menus set_deflt() ENDIF * draw the main View screen draw_view(0) CASE M->cur_area <> M->prev_area * horizontal movement detected (or initial entry) cur_dbf = dbf[M->cur_area] && current data file * save on function calls strn = SUBSTR("123456", M->cur_area, 1) * set variables to matrix into current data channel ntx = "ntx" + strn field_n = "field_n" + strn el = "el" + strn * use temporary variable for adjustment t_row = "cr" + strn IF M->page > 1 .AND. M->prev_area <> 0 * adjust element by (old row - new row) &el[M->page] = &el[M->page] +; &cur_row[M->page] - &t_row[M->page] * new row = old row &t_row[M->page] = &cur_row[M->page] ENDIF * set to current data channel cur_row = M->t_row * clear for next loop prev_area = M->cur_area CASE M->keystroke = 19 * left arrow..move one channel to the left IF M->cur_area > 1 * ok to move left cur_area = M->cur_area - 1 ENDIF keystroke = 0 CASE M->keystroke = 1 * home key..extreme left cur_area = 1 keystroke = 0 CASE M->keystroke = 4 * right arrow..move one channel to the right IF M->cur_area < 6 .AND. .NOT. EMPTY(M->cur_dbf) * ok to move right..next channel cur_area = M->cur_area + 1 IF EMPTY(dbf[M->cur_area]) * inactive channel..cannot enter indexes or fields page = 1 set_deflt() ENDIF ENDIF keystroke = 0 CASE M->keystroke = 6 * end key..move to extreme right IF M->cur_area < 6 .AND. .NOT. EMPTY(M->cur_dbf) * ok to move right..determine last active channel i = afull(M->dbf) IF M->i < 6 .AND. (M->page = 1 .OR. M->cur_area = M->i) * move to inactive channel cur_area = M->i + 1 * cannot enter indexes or fields page = 1 set_deflt() ELSE * move to last active channel cur_area = M->i ENDIF ENDIF keystroke = 0 CASE M->keystroke = 18 .OR. M->keystroke = 5 * PgUp or up arrow IF M->page > 1 * ok to move up page = M->page - 1 set_deflt() ENDIF keystroke = 0 CASE M->keystroke = 3 .OR. M->keystroke = 24 * PgDn or down arrow IF M->page < 3 .AND. .NOT. EMPTY(M->cur_dbf) * ok to move down page = M->page + 1 set_deflt() * adjust row and element for smooth cursor movement &el[M->page] = &el[M->page] -; (&cur_row[M->page] - row_a[M->page]) &cur_row[M->page] = row_a[M->page] ENDIF keystroke = 0 CASE M->keystroke = 22 .OR. M->keystroke = 13 .OR.; isdata(M->keystroke) .OR. (M->local_func = 2 .AND.; (M->local_sel = 1 .OR. M->local_sel = 2)) .OR.; (M->local_func = 8 .AND. M->local_sel = 3) * insert or enter or local menu item IF M->local_func <> 0 * local menu item..set page to menu selection page = M->local_sel set_deflt() * menu select behaves like insert keystroke = 22 ENDIF IF M->page = 1 .AND. M->n_files < 14 * open a data file is_redraw = M->cur_area < 6 .AND. (M->keystroke = 22 .OR.; EMPTY(M->cur_dbf)) is_insert = (M->keystroke = 22 .AND.; .NOT. EMPTY(M->cur_dbf) .AND. M->cur_area < 6) IF M->is_redraw * open up dummy channel on screen draw_view(M->cur_area) * a dummy for a dummy SetColor(M->color2) @ row_a[1], column[M->cur_area] + 2 SAY SPACE(8) SetColor(M->color1) ELSE * hilite the affected View item hi_cur() ENDIF * call the open function and save the return status ch_draw = open_dbf(M->is_insert, .F.) IF M->ch_draw * update screen with "channel" function channel(&ntx, &field_n, &el, &cur_row,; M->cur_area, M->cur_area) * new current data file cur_dbf = dbf[M->cur_area] ELSE * put the screen back the way it was IF M->is_redraw * kill the dummy draw_view(0) ELSE * un-hilite dehi_cur() ENDIF ENDIF ELSE IF M->page > 1 * pages 2 and 3 handled by channel function channel(&ntx, &field_n, &el, &cur_row,; M->cur_area, M->cur_area) ELSE error_msg("Too many files open") ENDIF ENDIF keystroke = 0 CASE M->keystroke = 7 * delete IF M->page = 1 .AND. .NOT. EMPTY(M->cur_dbf) * close this work area and shift subsequent ones down stat_msg("Closing File") clear_dbf(M->cur_area, 2) IF M->cur_area = 6 * no need to re-write screen..clear windows ch_draw = .T. channel(&ntx, &field_n, &el, &cur_row,; M->cur_area, M->cur_area) ELSE * re-write screen draw_view(0) ENDIF * new current data file cur_dbf = dbf[M->cur_area] * clear status message stat_msg("") ELSE IF M->page > 1 * pages 2 and 3 handled by channel function channel(&ntx, &field_n, &el, &cur_row,; M->cur_area, M->cur_area) ENDIF ENDIF keystroke = 0 CASE M->local_func = 8 .AND. M->local_sel = 1 * "set_relation" selected from pull-down menu set_relation() keystroke = 0 CASE M->local_func = 8 .AND. M->local_sel = 2 * "set filter" selected from pull-down menu get_filter() keystroke = 0 CASE M->local_func = 2 .AND. M->local_sel = 3 * "restore View from .VEW file" selected from pull-down menu set_from(.T.) IF .NOT. EMPTY(M->view_file) .AND. M->keystroke = 13 * View set..re-write screen cur_area = 0 cur_dbf = "" ENDIF keystroke = 0 CASE M->local_func = 4 * "save View" selected from pull-down menu save_view() keystroke = 0 CASE M->local_func = 1 * "help" selected from pull-down menu DO syshelp keystroke = 0 OTHERWISE * all pending cases have been processed DO CASE CASE M->page = 1 * get keystroke if pending IF .NOT. key_ready() * no key pending..hilite the current item hi_cur() * wait for keystroke read_key() * re-write the current item as normal dehi_cur() ENDIF CASE M->page = 2 * copy index file names to "name only" array d_copy(&ntx) * do the menu selection on the main View screen bar_menu(column[M->cur_area] + 2,; column[M->cur_area] + 9, M->d_array) CASE M->page = 3 * do the menu selection on the main View screen bar_menu(column[M->cur_area] + 1,; column[M->cur_area] + 10, &field_n) ENDCASE IF M->keystroke = 27 IF rsvp("Exit to DOS? (Y/N)") <> "Y" keystroke = 0 ENDIF ENDIF ENDCASE ENDDO IF M->sysfunc = 3 .AND. M->func_sel = 1 .AND. EMPTY(M->cur_dbf) * indicate create structure by opening a dummy channel draw_view(M->cur_area) ENDIF RETURN ****** * channel() * * process one channel for "set view" * * note: the array identifiers associated with the current * channel are passed to this function in order to * avoid the repeated macro expansion inherent in * constructs like &ntx[&el[]] ****** FUNCTION channel PARAMETERS ch_ntx, ch_field_n, ch_el, ch_cur_row, n, dbf_num local saveColor PRIVATE f_n, is_ins, temp_buff, d_item saveColor := SetColor(M->color1) DO CASE CASE M->ch_draw * update the screen for channel "n"..clear windows scroll(row_a[2], column[M->n], row_x[2], column[M->n] + 11, 0) scroll(row_a[3], column[M->n], row_x[3], column[M->n] + 11, 0) * display the specified file name "dbf_num" @ row_a[1],column[M->n] + 2 SAY pad(name(dbf[M->dbf_num]), 8) IF .NOT. EMPTY(ch_ntx[1]) * list the index files if any d_copy(M->ch_ntx) list_array(row_a[2],column[M->n] + 2,row_x[2],column[M->n] + 9,; M->d_array,ch_el[2] - (ch_cur_row[2] - row_a[2])) ENDIF * display field list list_array(row_a[3], column[M->n] + 1, row_x[3], column[M->n] + 10,; M->ch_field_n, ch_el[3] - (ch_cur_row[3] - row_a[3])) ch_draw = .F. && reset the screen update flag CASE M->keystroke = 22 .OR. M->keystroke = 13 .OR. isdata(M->keystroke) * insert or enter or character key IF isdata(M->keystroke) * forward character to GET system KEYBOARD CHR(M->keystroke) ENDIF * remember if insert is_ins = (M->keystroke = 22) DO CASE CASE M->page = 2 .AND. (M->n_files < 14 .OR. (M->keystroke <> 22; .AND. .NOT. EMPTY(ch_ntx[ch_el[2]]))) * add or change an index file in the current list..save window temp_buff = SAVESCREEN(row_a[2], column[M->n] + 1,; row_x[2], column[M->n] + 11) IF M->is_ins * insert IF ch_el[2] + row_x[2] - ch_cur_row[2] = afull(M->ch_ntx) * last filename will scroll off the window @ row_x[2], column[M->n] + 11 SAY M->more_down ENDIF IF ch_cur_row[2] < row_x[2] * open a blank row..scroll down scroll(ch_cur_row[2], column[M->n] + 1,; row_x[2], column[M->n] + 10, -1) ENDIF * show entry blank d_item = SPACE(8) ELSE * show the affected View item d_item = pad(name(ch_ntx[ch_el[2]]), 8) ENDIF * hilite the affected View item SetColor(M->color2) @ ch_cur_row[2],column[M->n] + 2 SAY M->d_item SetColor(M->color1) * get selection f_n = get_ntx(ch_cur_row[2], column[M->n] + 2,; ch_ntx[ch_el[2]], M->is_ins) IF .NOT. M->f_n == ch_ntx[ch_el[2]] .AND. .NOT. EMPTY(M->f_n) * index file added to list need_ntx = .T. IF M->is_ins * make room for new index file name array_ins(M->ch_ntx,ch_el[2]) ENDIF * assign filename to array element ch_ntx[ch_el[2]] = M->f_n IF ch_el[2] = 1 * controlling index..remove relations where target not_target(M->n, .T.) ENDIF * display the name of the newly selected index file @ ch_cur_row[2],column[M->n] + 2; SAY pad(name(ch_ntx[ch_el[2]]), 8) ELSE * aborted entry..restore the window as it was RESTSCREEN(row_a[2], column[M->n] + 1,; row_x[2], column[M->n] + 11, M->temp_buff) ENDIF CASE M->page = 3 * add or change a fieldname in the current list..save window temp_buff = SAVESCREEN(row_a[3], column[M->n] + 1,; row_x[3], column[M->n] + 11) IF M->is_ins * insert IF ch_el[3] + row_x[3] - ch_cur_row[3] = afull(M->ch_field_n) * last fieldname will scroll off the window @ row_x[3], column[M->n] + 11 SAY M->more_down ENDIF IF ch_cur_row[3] < row_x[3] * open a blank row..scroll down scroll(ch_cur_row[3], column[M->n] + 1,; row_x[3], column[M->n] + 10, -1) ENDIF * show entry blank d_item = SPACE(10) ELSE * show the affected View item d_item = pad(ch_field_n[ch_el[3]], 10) ENDIF * hilite the affected View item SetColor(M->color2) @ ch_cur_row[3],column[M->n] + 1 SAY M->d_item SetColor(M->color1) * get selection f_n = get_field(ch_cur_row[3], column[M->n] + 1, M->n,; ch_field_n[ch_el[3]]) IF (M->is_ins .OR. .NOT. M->f_n == ch_field_n[ch_el[3]]); .AND. .NOT. EMPTY(M->f_n) * fieldname added to list need_field = .T. IF M->is_ins * make room for new field name array_ins(M->ch_field_n,ch_el[3]) ENDIF * assign fieldname to array element ch_field_n[ch_el[3]] = M->f_n * display the name of the newly selected field @ ch_cur_row[3],column[M->n] + 1; SAY pad(ch_field_n[ch_el[3]], 10) ELSE * aborted entry..restore the window as it was RESTSCREEN(row_a[3], column[M->n] + 1,; row_x[3], column[M->n] + 11, M->temp_buff) ENDIF ENDCASE CASE M->keystroke = 7 * delete DO CASE CASE M->page = 2 .AND. .NOT. EMPTY(ch_ntx[ch_el[2]]) * remove index file from list need_ntx = .T. && must reset IF ch_el[2] = 1 * primary index..remove relations where target not_target(M->n, .T.) ENDIF * select work area n SELECT (M->n) * ensure that n_files does not exceed actual open files CLOSE INDEX * remove the filename from the list array_del(M->ch_ntx,ch_el[2]) * decrement global file counter n_files = M->n_files - 1 IF ch_cur_row[2] < row_x[2] * scroll up to remove filename from screen scroll(ch_cur_row[2],column[M->n] + 1,; row_x[2],column[M->n] + 9,1) ENDIF * fill in blank row at bottom of window @ row_x[2],column[M->n] + 2; SAY pad(name(ch_ntx[ch_el[2] + row_x[2] - ch_cur_row[2]]), 8) IF afull(M->ch_ntx) - ch_el[2] = row_x[2] - ch_cur_row[2] * remove the "more_down" indicator from the screen @ row_x[2],column[M->n] + 11 SAY " " ENDIF CASE M->page = 3 .AND. .NOT. EMPTY(ch_field_n[ch_el[3]]) * delete a fieldname from the current list need_field = .T. && must reset * remove the fieldname from the list array_del(M->ch_field_n,ch_el[3]) IF ch_cur_row[3] < row_x[3] * scroll up to remove fieldname from screen scroll(ch_cur_row[3],column[M->n] + 1,; row_x[3],column[M->n] + 10,1) ENDIF * fill in blank row at bottom of window @ row_x[3],column[M->n] + 1; SAY pad(ch_field_n[ch_el[3] + row_x[3] - ch_cur_row[3]], 10) IF afull(M->ch_field_n) - ch_el[3] = row_x[3] - ch_cur_row[3] * remove the "more_down" indicator from the screen @ row_x[3],column[M->n] + 11 SAY " " ENDIF ENDCASE ENDCASE SetColor(saveColor) RETURN 0 ****** * bar_menu() * * verticle light bar selection menu for the main View screen * * note: this routine is expected to return a value in "keystroke" * to be processed by "set_view" ****** FUNCTION bar_menu PARAMETERS l, r, array local saveColor PRIVATE num_d, num_full, cur_el, rel_row, x, t, b * look ahead at next keystroke keystroke = NEXTKEY() IF CHR(M->keystroke) $ M->horiz_keys * improve performance of horizontal cursor movement with quick return INKEY() && remove character from typeahead buffer RETURN 0 ENDIF * avoid costly array access by getting top and bottom of window to "t" and "b" t = row_a[M->page] b = row_x[M->page] * get the number of active elements num_full = afull(M->array) * and the number of displayable elements num_d = M->num_full IF M->num_d < LEN(M->array) * first empty element is included num_d = M->num_d + 1 * achoice() won't display a null string array[M->num_d] = " " ENDIF * determine column offset to put "more_up" and "more_down" indicators x = IF(M->r - M->l > 7, 1, 2) * it's all relative to achoice() rel_row = &cur_row[M->page] - M->t * discard returned value saveColor := SetColor(M->color4) achoice(M->t, M->l, M->b, M->r, M->array, .T.,; "bar_func", &el[M->page], M->rel_row) SetColor(saveColor) * change back to absolute &cur_row[M->page] = M->rel_row + M->t IF array[M->num_d] == " " * kill the dummy array[M->num_d] = "" ENDIF * check for menu request sysmenu() RETURN 0 ****** * bar_func() * * function to be called from achoice() specifically for bar_menu() ****** FUNCTION bar_func PARAMETERS mode, bar_el, row PRIVATE ret_code * get keystroke keystroke = LASTKEY() * assume continue ret_code = 2 * maintain variables from above &el[M->page] = M->bar_el rel_row = M->row IF M->error_on * erase error message error_off() ENDIF DO CASE CASE M->mode = 0 * idle..maintain correct "more_up" and "more_down" indicators @ M->t, M->r + M->x SAY IF(M->bar_el > M->row + 1, M->more_up, " ") @ M->b, M->r + M->x SAY IF(M->num_full >; (M->bar_el + M->b - M->t - M->row),; M->more_down, " ") CASE M->mode = 1 .OR. M->mode = 2 * attempt to cursor past top or end of list ret_code = 0 CASE M->mode = 3 * keystroke exception DO CASE CASE CHR(M->keystroke) $ M->horiz_keys * horizontal cursor key ret_code = 0 CASE M->keystroke = 27 * abort selection ret_code = 0 CASE M->keystroke = 13 * replace a View item ret_code = 1 CASE isdata(M->keystroke) * character key...entry in place ret_code = 1 CASE M->keystroke = 22 .OR. M->keystroke = 7 * ins, del ret_code = 1 CASE menu_key() <> 0 * menu request ret_code = 0 ENDCASE CASE M->mode = 4 * nothing selectable ret_code = 0 ENDCASE RETURN M->ret_code ****** * list_array() * * list array elements vertically in window ****** FUNCTION list_array PARAMETERS t, l, b, r, array, top_el local saveColor PRIVATE bottom_el, num_full, x saveColor := SetColor(M->color4) IF .NOT. EMPTY(array[M->top_el]) * something to list..calculate number of last element in window bottom_el = M->top_el + M->b - M->t * get number of non-empty elements num_full = afull(M->array) * determine column offset of "more_up" and "more_down" indicators x = IF(M->r - M->l > 7, 1, 2) IF M->top_el > 1 .AND. M->bottom_el = M->num_full + 1 * prevent achoice() from making adjustments array[M->bottom_el] = " " ENDIF * display only and return without waiting for a keystroke achoice(M->t, M->l, M->b, M->r, M->array, .F., "", M->top_el) SetColor(M->color1) * update status of "more_up" and "more_down" indicators @ M->t, M->r + M->x SAY IF(M->top_el > 1, M->more_up, " ") @ M->b, M->r + M->x SAY IF(M->bottom_el < M->num_full, M->more_down, " ") IF array[M->bottom_el] == " " * restore to null string array[M->bottom_el] = "" ENDIF ENDIF SetColor(saveColor) RETURN 0 ****** * set_deflt() * * set defaults for open and create pull-down menus ****** FUNCTION set_deflt IF M->page = 2 * cursor in index file list..default to open index and create index STORE 2 TO menu_deflt[2], menu_deflt[3] ELSE * default to open database and create database STORE 1 TO menu_deflt[2], menu_deflt[3] ENDIF RETURN 0 ****** * bline() * * build a new bar line for the main View screen ****** FUNCTION bline PARAMETERS num_slots PRIVATE i, k IF num_slots < 6 * add one empty slot num_slots = num_slots + 1 ENDIF * the first slot is diferent than the rest bar_line = "════════════" empty_line = "" k = 1 DO WHILE M->k < M->num_slots * each new slot separated from previous by a vertical line bar_line = M->bar_line + "╤════════════" empty_line = M->empty_line + SPACE(12) + "│" * next k = M->k + 1 ENDDO * calculate value to center the entire View screen i = INT((80 - LEN(M->bar_line)) / 2) FOR k = 1 TO M->num_slots * establish screen columns for all active slots column[M->k] = M->i + (13 * (M->k - 1)) NEXT RETURN 0 ****** * draw_view() * * fill the main View screen * * note: the parameter indicates which channel is to be the * dummy for operations in progress, zero for no dummy ****** FUNCTION draw_view PARAMETERS blank_area PRIVATE i, j, ntx, field_n, el, cur_row, strnum * get number of active work areas i = afull(M->dbf) IF M->i < 6 .AND. blank_area <> 0 * add one for the dummy i = M->i + 1 ENDIF * build the bar_line and empty_line strings bline(M->i) * clear the deck and draw a blank template @ 4,0 CLEAR * page 1..names of data files @ row_a[1] - 2,37 SAY "Files" @ row_a[1] - 1,column[1] SAY M->bar_line @ row_a[1],column[1] SAY M->empty_line * page 2..names of index files @ row_a[2] - 2,36 SAY "Indexes" @ row_a[2] - 1,column[1] SAY M->bar_line @ row_a[2],column[1] SAY M->empty_line @ row_a[2] + 1,column[1] SAY M->empty_line @ row_a[2] + 2,column[1] SAY M->empty_line * page 3..active fields lists @ row_a[3] - 2,37 SAY "Fields" @ row_a[3] - 1,column[1] SAY M->bar_line FOR i = row_a[3] TO row_x[3] * complete the blank template @ M->i,column[1] SAY M->empty_line NEXT i = 1 j = 1 DO WHILE M->j <= 6 IF EMPTY(dbf[M->i]) * no more active work areas EXIT ENDIF IF M->j <> M->blank_area * channel needs filling strnum = SUBSTR("123456", M->i, 1) * set to channel "i" ntx = "ntx" + strnum field_n = "field_n" + strnum el = "el" + strnum cur_row = "cr" + strnum * fill the channel ch_draw = .T. channel(&ntx, &field_n, &el, &cur_row, M->j, M->i) * next real channel i = M->i + 1 ENDIF * next display channel j = M->j + 1 ENDDO RETURN 0 ****** * d_copy() * * create a filename only array (no paths or extensions) ****** FUNCTION d_copy PARAMETERS array PRIVATE i * clear the dedicated array afill(M->d_array, "") i = 1 DO WHILE M->i <= LEN(M->array) IF EMPTY(array[M->i]) * end of active list EXIT ENDIF * assign the extracted name d_array[M->i] = name(array[M->i]) * next i = M->i + 1 ENDDO RETURN 0 ****** * open_dbf() * * open data file in the specified work area ****** FUNCTION open_dbf PARAMETERS is_insert, not_view PRIVATE shift, filename, a_temp, f_row, d_col, ret_val, old_help IF M->n_files >= 14 error_msg("Too many files open") RETURN .F. ENDIF * save old and set new help codes old_help = M->help_code help_code = 6 * initialize private variables filename = "" * coordinate of filename on View screen f_row = cr1[1] d_col = column[M->cur_area] + 2 * shift = 1 for major insertion shift = IF(M->is_insert, 1, 0) * select the current work area SELECT (M->cur_area) IF M->not_view * not called from "set_view" filename = M->cur_dbf ret_val = do_opendbf() ELSE * assume file not opened ret_val = .F. IF isdata(M->keystroke) * forward the data character to the GET system KEYBOARD CHR(M->keystroke) * entry in place filename = enter_rc(dbf[M->cur_area],M->f_row,M->d_col,64,"@K!S8",; M->color1) IF .NOT. EMPTY(M->filename) * something entered IF .NOT. (RAT(".", M->filename) > RAT("\", M->filename)) * no extension entered..provide default filename = M->filename + ".DBF" ENDIF * try to open the file ret_val = do_opendbf() IF .NOT. M->ret_val * failed..restore the screen @ M->f_row, M->d_col SAY pad(name(M->cur_dbf), 8) ENDIF ELSE * aborted entry..restore the screen @ M->f_row, M->d_col SAY pad(name(M->cur_dbf), 8) ENDIF IF menu_key() <> 0 * forward menu key to "set_view" KEYBOARD CHR(M->keystroke) ELSE * avoid confusion keystroke = 0 ENDIF ELSE * insert or enter or menu selection..use filebox ret_val = filebox(".DBF", "dbf_list", "dopen_titl",; "do_opendbf", .F., 8) <> 0 ENDIF ENDIF IF M->ret_val * default field arrays to all fields a_temp = "field_n" + SUBSTR("123456", M->cur_area, 1) all_fields(M->cur_area, &a_temp) * re-set current row for indexes and fields a_temp = "cr" + SUBSTR("123456", M->cur_area, 1) &a_temp[2] = row_a[2] &a_temp[3] = row_a[3] * re-set current elements a_temp = "el" + SUBSTR("123456", M->cur_area, 1) afill(&a_temp, 1) ENDIF * restore help code help_code = M->old_help RETURN M->ret_val ****** * dopen_titl() * * display title for data file to open ****** FUNCTION dopen_titl PARAMETERS sysparam RETURN box_title(M->sysparam, "Open data file...") ****** * do_opendbf() * * set up and open a data file ****** FUNCTION do_opendbf PRIVATE done DO CASE CASE EMPTY(M->filename) error_msg("Data file not selected") done = .F. CASE .NOT. FILE(M->filename) error_msg("Can't open " + M->filename) done = .F. CASE aseek(M->dbf, M->filename) > 0 .AND.; .NOT. (dbf[M->cur_area] == M->filename .AND. M->shift = 0) error_msg("Data file would be open in two areas") done = .F. OTHERWISE stat_msg("Opening File") IF .NOT. EMPTY(dbf[M->cur_area]) * clear the current work area clear_dbf(M->cur_area, M->shift) ENDIF * adjust global variable n_files = M->n_files + 1 * assign the filename to global array dbf[M->cur_area] = M->filename * open the file in the current area SELECT (M->cur_area) USE &filename * clear the message stat_msg("") done = .T. ENDCASE RETURN M->done ****** * get_ntx() * * select index files for the current work area ****** FUNCTION get_ntx PARAMETERS d_row, d_col, org_file, is_ins PRIVATE filename, old_help IF M->n_files >= 14 error_msg("Too many files open") RETURN "" ENDIF * save old and set new help codes old_help = M->help_code help_code = 8 * initialize private variable filename = "" IF isdata(M->keystroke) * forward data keystroke to GET system KEYBOARD CHR(M->keystroke) * entry in place filename = enter_rc(M->org_file,M->d_row,M->d_col,64,"@K!S8",M->color1) IF .NOT. EMPTY(M->filename) * something entered IF .NOT. (RAT(".", M->filename) > RAT("\", M->filename)) * extension not entered..provide default filename = filename + INDEXEXT() ENDIF IF .NOT. do_openntx() * failed..return null string filename = "" ENDIF ENDIF IF menu_key() <> 0 * forward menu request to "set_view" KEYBOARD CHR(M->keystroke) ELSE * avoid confusion keystroke = 0 ENDIF ELSE IF filebox(INDEXEXT(),"ntx_list","xopen_titl","do_openntx",.F.,13) = 0 * no selection..return null string filename = "" ENDIF ENDIF * restore help code help_code = M->old_help RETURN M->filename ****** * xopen_titl() * * display title for index file to open ****** FUNCTION xopen_titl PARAMETERS sysparam RETURN box_title(M->sysparam, "Open index file...") ****** * do_openntx() * * verify the selectability of an index file ****** FUNCTION do_openntx PRIVATE done DO CASE CASE EMPTY(M->filename) error_msg("Index file not selected") done = .F. CASE .NOT. FILE(M->filename) error_msg("Can't open " + M->filename) done = .F. CASE dup_ntx(M->filename) <> 0 .AND.; (M->is_ins .OR. .NOT. M->filename == M->org_file) error_msg("Index file already open") done = .F. OTHERWISE * filename may be selected IF EMPTY(M->org_file) .OR. M->is_ins * adjust global variable n_files = M->n_files + 1 ENDIF done = .T. ENDCASE RETURN M->done ****** * get_field() * * add a field to an individual field list ****** FUNCTION get_field PARAMETERS f_row, d_col, work_area, org_field PRIVATE field_mvar, rel_row, cur_el, okee_dokee, fi_disp, old_help * save old and set new help codes old_help = M->help_code help_code = 2 * initialize variable to contain fieldname field_mvar = "" * select the specified work area SELECT (M->work_area) * get master field list into local array for selection DECLARE field_m[FCOUNT()] all_fields(M->work_area, M->field_m) IF isdata(M->keystroke) * forward the data keystroke to the GET system KEYBOARD CHR(M->keystroke) * entry in place field_mvar = enter_rc(M->org_field,M->f_row,M->d_col,10,"@K!",M->color1) IF .NOT. EMPTY(M->field_mvar) * something entered IF .NOT. do_fsel() * failed..return null string field_mvar = "" ENDIF ENDIF IF menu_key() <> 0 * forward the menu request to "set_view" KEYBOARD CHR(M->keystroke) ELSE * avoid confusion keystroke = 0 ENDIF ELSE * establish arrays for multibox DECLARE boxarray[5] boxarray[1] = "fsel_title(sysparam)" boxarray[2] = "getfield(sysparam)" boxarray[3] = "ok_button(sysparam)" boxarray[4] = "can_button(sysparam)" boxarray[5] = "fieldlist(sysparam)" * initialize private variables cur_el = 1 rel_row = 0 * where the action is okee_dokee = "do_fsel()" fi_disp = "getfield(3)" IF multibox(7, 17, 5, 5, M->boxarray) = 0 * failed or aborted..return null string field_mvar = "" ENDIF ENDIF * restore help code help_code = M->old_help RETURN M->field_mvar ****** * getfield() * * process fieldname entry blank (called from multibox) ****** FUNCTION getfield PARAMETERS sysparam RETURN genfield(M->sysparam, .F.) ****** * fsel_title() * * display title for field selection ****** FUNCTION fsel_title PARAMETERS sysparam RETURN box_title(M->sysparam, "Select field...") ****** * do_fsel() * * validate field selection ****** FUNCTION do_fsel PRIVATE done DO CASE CASE EMPTY(M->field_mvar) error_msg("Field name not selected") done = .F. CASE aseek(M->field_m, M->field_mvar) = 0 * needed for entry in place error_msg(M->field_mvar + " does not exist") done = .F. OTHERWISE * field exists..no problem done = .T. ENDCASE RETURN M->done ****** * set_relation() * * interface for editing the list of relations * * note: the relations window can display a maximum * of six (6) relationships at one time ****** FUNCTION set_relation local saveColor PRIVATE c_row, c_el, rel_buff, pos_r, width, old_help, k, n_area, ls, lk, lt,; cNorm, cHilite cNorm := color7 cHilite:= color2 saveColor := SetColor(M->cNorm) * save old and set new help codes old_help = M->help_code help_code = 9 * prevent certain menu selections with multibox mechanism box_open = .T. IF EMPTY(M->bar_line) * need bar line for vertical reference bline(afull(M->dbf)) ENDIF * window has variable width width = LEN(M->bar_line) - 1 * establish easy reference to right most column pos_r = column[1] + M->width * save the window rel_buff = SAVESCREEN(8, column[1] - 1, 23, M->pos_r + 1) * clear and frame the window scroll(8, column[1] - 1, 23, M->pos_r + 1, 0) @ 8, column[1] - 1, 23, M->pos_r + 1 BOX M->frame * display the heading and bar line @ 9,35 SAY "Relations" @ 10,column[1] SAY M->bar_line * initialize current row and element c_row = 11 c_el = 1 * initial window fill draw_relat(1) * global key value..zero is convenient for branch to "otherwise" case below keystroke = 0 DO WHILE .NOT. q_check() * one big switch..exit condition determined elsewhere DO CASE CASE M->keystroke = 18 * PgUp IF M->c_el > ((M->c_row - 11) / 2) + 1 * elements off screen..move up one page c_el = M->c_el - 5 IF M->c_el < ((M->c_row - 11) / 2) + 1 * minimum element for this row c_el = ((M->c_row - 11) / 2) + 1 ENDIF * re-write relations window draw_relat(M->c_el - ((M->c_row - 11) / 2)) ELSE * first element is on screen IF M->c_el > 1 * move to top of list c_el = 1 c_row = 11 ENDIF ENDIF keystroke = 0 CASE M->keystroke = 3 * PgDn..determine maximum allowable cursor element k = afull(M->k_relate) IF M->k < LEN(M->k_relate) * first empty element is allowed k = M->k + 1 ENDIF IF M->c_el < M->k - ((21 - M->c_row) / 2) * elements off screen..down one page c_el = M->c_el + 5 IF M->c_el > M->k - ((21 - M->c_row) / 2) * maximum element for this row c_el = M->k - ((21 - M->c_row) / 2) ENDIF * re-write relations window draw_relat(M->c_el - ((M->c_row - 11) / 2)) ELSE * last allowable element is on screen IF M->c_el < M->k * move to bottom of list c_row = M->c_row + ((M->k - M->c_el) * 2) c_el = M->k ENDIF ENDIF keystroke = 0 CASE M->keystroke = 22 .OR. isdata(M->keystroke) * insert or character key..insert a relation * k = number of first relation off screen k = M->c_el + ((21 - M->c_row) / 2 ) + 1 * save the last relationship ls = s_relate[LEN(M->s_relate)] lk = k_relate[LEN(M->k_relate)] lt = t_relate[LEN(M->t_relate)] * do the insert..assume relation will be entered array_ins(M->s_relate, M->c_el) array_ins(M->k_relate, M->c_el) array_ins(M->t_relate, M->c_el) IF M->c_row < 21 * make room on screen..scroll down 2 lines scroll(M->c_row, column[1], 22, M->pos_r - 1, -2) ELSE * clear the last row @ M->c_row + 1,column[1] SAY SPACE(M->width) ENDIF IF M->k <= LEN(M->k_relate) * k is within subscript range IF .NOT. EMPTY(k_relate[M->k]) * off-screen element is active @ 22, M->pos_r SAY M->more_down ENDIF ENDIF * accept input of new relation get_relation(M->c_row, M->c_el) IF .NOT. EMPTY(k_relate[M->c_el]) * relation has been entered..show it disp_relation(M->c_row, M->c_el, color7) ELSE * relation not entered..cannot delete a null string STORE "x" TO s_relate[M->c_el],; k_relate[M->c_el], t_relate[M->c_el] * restore arrays array_del(M->s_relate, M->c_el) array_del(M->k_relate, M->c_el) array_del(M->t_relate, M->c_el) * restore last relationship s_relate[LEN(M->s_relate)] = M->ls k_relate[LEN(M->k_relate)] = M->lk t_relate[LEN(M->t_relate)] = M->lt IF M->c_row < 21 * close the gap on the screen..scroll up 2 lines scroll(M->c_row, column[1], 22, M->pos_r - 1, 2) ELSE * erase the deleted relation from screen @ 21,column[1] SAY SPACE(M->width) @ 22,column[1] SAY SPACE(M->width) ENDIF * fill in the last relation on screen disp_relation(21,M->c_el+((21-M->c_row)/2),color7) ENDIF IF M->k <= LEN(M->k_relate) * k is within subscript range IF EMPTY(k_relate[M->k]) * off-screen element not active @ 22, M->pos_r SAY " " ENDIF ENDIF keystroke = 0 CASE M->keystroke = 13 * enter key..change a relationship get_relation(M->c_row, M->c_el) * display the change disp_relation(M->c_row, M->c_el, color7) keystroke = 0 CASE M->keystroke = 7 .AND. .NOT. EMPTY(k_relate[M->c_el]) * remove a relation from the list need_relat = .T. && will need to reset * select the source work area n_area = ASC(s_relate[M->c_el]) - ASC("A") + 1 SELECT (M->n_area) * turn off relations from this work area SET RELATION TO * remove the relation from list array_del(M->s_relate, M->c_el) array_del(M->k_relate, M->c_el) array_del(M->t_relate, M->c_el) IF M->c_row < 21 * close the gap on the screen scroll(M->c_row, column[1], 22, M->pos_r - 1, 2) ELSE * last row erase the deleted relation from screen @ 21,column[1] SAY SPACE(M->width) @ 22,column[1] SAY SPACE(M->width) ENDIF * fill in the last relation on screen disp_relation(21, M->c_el + ((21 - M->c_row) / 2), color7) IF M->c_el < LEN(M->k_relate) - ((21 - M->c_row) / 2) * off-screen element is within subscript range IF EMPTY(k_relate[M->c_el + ((21 - M->c_row) / 2) + 1]) * remove "more_down" indicator from screen @ 22, M->pos_r SAY " " ENDIF ENDIF keystroke = 0 CASE M->keystroke = 5 .AND. M->c_el > 1 * up arrow..move up one element c_el = M->c_el - 1 IF M->c_row > 11 * room to move up on screen c_row = M->c_row - 2 ELSE * scroll entire window down 2 lines scroll(11, column[1], 22, M->pos_r - 1, -2) * fill in the top row disp_relation(11, M->c_el, color7) IF M->c_el <= LEN(M->k_relate) - 6 * off-screen element within subscript range IF .NOT. EMPTY(k_relate[M->c_el + 6]) * off-screen element is active @ 22, M->pos_r SAY M->more_down ENDIF ENDIF IF M->c_el = 1 * first element brought onto screen..no "more_up" @ 11,M->pos_r SAY " " ENDIF ENDIF keystroke = 0 CASE M->keystroke = 24 .AND. .NOT.; (EMPTY(k_relate[M->c_el]) .OR. M->c_el = LEN(M->k_relate)) * down arrow..move down one element c_el = M->c_el + 1 IF c_row < 22 - 2 * room to move down on screen c_row = M->c_row + 2 ELSE * scroll entire window up 2 lines scroll(11, column[1], 22, M->pos_r - 1, 2) * definitely more up @ 11,M->pos_r SAY M->more_up IF .NOT. EMPTY(k_relate[M->c_el]) * fill in the bottom row disp_relation(21, M->c_el, color7) ENDIF IF M->c_el < LEN(M->k_relate) * off-screen element within subscript range IF EMPTY(k_relate[M->c_el + 1]) * erase "more_down" indicator from screen @ 22,M->pos_r SAY " " ENDIF ELSE * no off-screen element..erase "more_down" indicator @ 22,M->pos_r SAY " " ENDIF ENDIF keystroke = 0 CASE M->local_func = 1 * "help" selected from pull-down menu DO syshelp keystroke = 0 OTHERWISE * get new keystroke IF .NOT. key_ready() * no key pending..hilite the current item disp_relation(M->c_row, M->c_el, cHilite) * display a blob of light if element empty SetColor(M->cHilite) @ M->c_row,column[1] + 2; SAY IF(EMPTY(k_relate[M->c_el]), " ", "") SetColor(M->cNorm) * wait for keystroke read_key() * re-write the current item as normal disp_relation(M->c_row, M->c_el, cNorm) @ M->c_row, column[1] + 2 SAY "" ENDIF ENDCASE ENDDO * restore the window RESTSCREEN(8, column[1] - 1, 23, M->pos_r + 1, M->rel_buff) * restore the help code help_code = M->old_help * restore access to menu options box_open = .F. * avoid confusion keystroke = 0 SetColor(saveColor) RETURN 0 ****** * draw_relat() * * fill the relations window ****** FUNCTION draw_relat PARAMETERS start_el PRIVATE i * clear the window scroll(11, column[1], 22, M->pos_r, 0) i = 0 DO WHILE M->i < 6 .AND. M->start_el + M->i <= LEN(M->k_relate) IF EMPTY(k_relate[M->start_el + M->i]) * end of active list EXIT ENDIF * display one relation disp_relation(11 + (2 * M->i), M->start_el + M->i, color7) * next i = M->i + 1 ENDDO IF M->start_el > 1 * indicate active elements above window @ 11, M->pos_r SAY M->more_up ENDIF IF M->start_el + M->i <= LEN(M->k_relate) * off-screen element within subscript range IF .NOT. EMPTY(k_relate[M->start_el + M->i]) * indicate active elements below window @ 22, M->pos_r SAY M->more_down ENDIF ENDIF RETURN 0 ****** * get_relation() * * accept entry of one relationship * * note: a character key may be used to select a file whose * name begins with that letter ****** FUNCTION get_relation PARAMETERS row_n, element PRIVATE stroke, k_input, k_trim, s_alias, t_alias, i, j, q, pos_c,; ntx_expr, k_type, ok IF isdata(M->keystroke) * character key..look for matching filename i = c_search(UPPER(CHR(M->keystroke)), M->dbf, 0, afull(M->dbf)) IF SUBSTR(dbf[M->i],1,1) = UPPER(CHR(M->keystroke)) * found..make the selection as the source file KEYBOARD CHR(13) ENDIF ELSE IF EMPTY(k_relate[M->element]) * brand new..start at the beginning i = 1 ELSE * relation exists..begin with source file i = ASC(s_relate[M->element]) - ASC("A") + 1 ENDIF ENDIF j = 0 stroke = 0 DO WHILE .NOT. (M->j > 0 .AND. M->stroke = 13) * till both source and target files are selected DO CASE CASE M->stroke = 13 * enter key..select source IF M->i < 6 * can only select if another file is open to the right IF .NOT. EMPTY(dbf[M->i + 1]) IF .NOT. EMPTY(k_relate[M->element]) * assume same target for existing relation j = ASC(t_relate[M->element]) - ASC("A") + 1 ENDIF IF M->j <= M->i * target must be to the right of the source j = M->i + 1 ENDIF ENDIF ENDIF stroke = 0 CASE M->stroke = 4 * right arrow IF M->j = 0 .AND. M->i < 6 * source not selected..change source IF .NOT. EMPTY(dbf[M->i + 1]) * only open files are selectable i = M->i + 1 ENDIF ELSE IF M->j > 0 .AND. M->j < 6 * source selected..change target IF .NOT. EMPTY(dbf[M->j + 1]) * only open files are selectable j = M->j + 1 ENDIF ENDIF ENDIF stroke = 0 CASE M->stroke = 19 * left arrow IF M->j = 0 .AND. M->i > 1 * source not selected..change source i = M->i - 1 ELSE IF M->j > 0 * source selected..change target j = M->j - 1 IF M->j = M->i * target must be to the right j = 0 && revert to unselected source ENDIF ENDIF ENDIF stroke = 0 CASE isdata(M->stroke) * character key..perform character search q = c_search(UPPER(CHR(M->stroke)),M->dbf,M->i,afull(M->dbf)) IF SUBSTR(dbf[M->q],1,1) = UPPER(CHR(M->stroke)) * found IF M->j = 0 * source not selected..make selection i = M->q KEYBOARD CHR(13) ELSE IF M->q > M->i * found file is acceptable as target..make selection j = M->q KEYBOARD CHR(13) ELSE * found file cannot be target j = 0 && revert to unselected source i = M->q && found file is current s_alias ENDIF ENDIF ENDIF stroke = 0 CASE M->stroke = 27 * escape..abort @ M->row_n,column[1] SAY SPACE(M->width) RETURN 0 CASE M->stroke = 28 * "help" selected from pull-down menu DO syshelp stroke = 0 OTHERWISE * update screen and get new stroke IF M->j = 0 * source file not selected..clear the row @ M->row_n,column[1] SAY SPACE(M->width) * extract the current source alias s_alias = name(dbf[M->i]) * display it as intense SetColor(M->color12) @ M->row_n,column[M->i] + 2 SAY M->s_alias SetColor(M->cNorm) ELSE * source selected (do not disturb)..extract target alias t_alias = name(dbf[M->j]) * calculate column after s_alias pos_c = column[M->i] + 2 + LEN(M->s_alias) * clear to right edge of window @ M->row_n,M->pos_c SAY SPACE(M->pos_r - M->pos_c) * draw line and arrow pointing to target alias @ M->row_n,M->pos_c; SAY REPLICATE("─", column[M->j] - M->pos_c + 1) + CHR(16) * display target alias as intense SetColor(M->color12) ?? t_alias SetColor(M->cNorm) ENDIF * get new stroke stroke = raw_key() ENDCASE ENDDO * hilite source and target in reverse video to indicate both selected SetColor(M->cHilite) @ M->row_n,column[M->i] + 2 SAY M->s_alias @ M->row_n,column[M->j] + 2 SAY M->t_alias SetColor(M->cNorm) * determine correct type for relation expression SELECT (M->j) ntx_expr = ctrl_key() && get the controlling index key IF EMPTY(M->ntx_expr) * target not indexed..must be numeric or recno() k_type = "N" ELSE * same type as target index key k_type = TYPE(M->ntx_expr) ENDIF * select source work area to test key expression SELECT (M->i) * start with previous expression k_trim = k_relate[M->element] ok = .F. DO WHILE .NOT. M->ok * accept input of key expression k_trim = enter_rc(M->k_trim, M->row_n + 1, column[M->i] + 2,; 127, "@KS" + LTRIM(STR(M->pos_r - column[M->i] - 2)),; M->color1) * empty expression will abort, else must be correct type ok = EMPTY(M->k_trim) .OR. TYPE(M->k_trim) = M->k_type IF .NOT. M->ok error_msg("Invalid Expression") ENDIF ENDDO * clear the expression row @ M->row_n + 1,column[1] SAY SPACE(M->width) IF EMPTY(M->k_trim) * abort RETURN 0 ENDIF * will need to set relations need_relat = .T. * store defined relation in global arrays k_relate[M->element] = M->k_trim s_relate[M->element] = CHR(M->i + ASC("A") - 1) + M->s_alias t_relate[M->element] = CHR(M->j + ASC("A") - 1) + M->t_alias RETURN 0 ****** * disp_relation() * * display the specified relation on the specified row in the specified color ****** FUNCTION disp_relation PARAMETERS disp_row, element, cSpecial PRIVATE j, k IF EMPTY(k_relate[M->element]) * clear lines only @ M->disp_row,column[1] SAY SPACE(M->width) @ M->disp_row + 1,column[1] SAY SPACE(M->width) RETURN 0 ENDIF * calculate the work areas of the related files j = ASC(s_relate[M->element]) - ASC("A") + 1 && source k = ASC(t_relate[M->element]) - ASC("A") + 1 && target * display the source alias in the specified color SetColor(M->cSpecial) @ M->disp_row, column[M->j] + 2 SAY SUBSTR(s_relate[M->element], 2) SetColor(M->cNorm) * display an arrow (always normal color) ?? REPLICATE("─", column[M->k] - COL() + 1) + CHR(16) * display the target alias in the specified color SetColor(M->cSpecial) ?? SUBSTR(t_relate[M->element], 2) SetColor(M->cNorm) * display the key on the next line (always normal color) @ M->disp_row + 1, column[M->j] + 2; SAY pad(k_relate[M->element], M->pos_r - column[M->j] - 2) RETURN 0 ****** * c_search() * * find the next array element with a matching first character ****** FUNCTION c_search PARAMETERS c, array, cur_el, num_d PRIVATE chr_el * begin with next element chr_el = M->cur_el + 1 DO WHILE M->chr_el <= M->num_d * forward search..exit if found IF UPPER(SUBSTR(array[M->chr_el], 1, 1)) = UPPER(M->c) EXIT ENDIF * next chr_el = M->chr_el + 1 ENDDO IF M->chr_el > M->num_d * not found..search from beginning chr_el = 1 DO WHILE M->chr_el < M->cur_el .AND.; UPPER(SUBSTR(array[M->chr_el], 1, 1)) <> UPPER(M->c) * next chr_el = M->chr_el + 1 ENDDO ENDIF RETURN M->chr_el ****** * ctrl_key() * * return controlling index key for the current work area ****** FUNCTION ctrl_key PRIVATE key, ntx IF M->need_ntx * index may be specified but not set ntx = "ntx" + LTRIM(STR(SELECT())) * read key directly from file key = ntx_key(&ntx[1]) ELSE * get key from system if index already set key = INDEXKEY(0) ENDIF RETURN M->key ****** * get_filter() * * accept entry of filter expression for the current work area ****** FUNCTION get_filter PRIVATE k_filter,k_trim,old_help * save old and set new help codes old_help = M->help_code help_code = 7 * get the current contents of the filter expression k_filter = "kf" + SUBSTR("123456", M->cur_area, 1) k_trim = &k_filter * select the current work area for testing of filter expression SELECT (M->cur_area) * hilite the affected data file hi_cur() * establish array for mulitbox DECLARE boxarray[4] boxarray[1] = "fltr_title(sysparam)" boxarray[2] = "getfilter(sysparam)" boxarray[3] = "ok_button(sysparam)" boxarray[4] = "can_button(sysparam)" * indicate the function that will complete the process okee_dokee = "do_filter()" * open the box multibox(7, 17, 5, 2, M->boxarray) * restore help code help_code = M->old_help * un-hilite the name of the current data file dehi_cur() RETURN 0 ****** * fltr_title() * * display title for filter entry ****** FUNCTION fltr_title PARAMETERS sysparam * title includes filename.ext but no path RETURN box_title(M->sysparam, "Set filter for " +; SUBSTR(M->cur_dbf, RAT("\", M->cur_dbf) + 1) +; " to...") ****** * getfilter() * * accept input of filter expression to the temporary variable "k_trim" ****** FUNCTION getfilter PARAMETERS sysparam RETURN get_k_trim(M->sysparam, "Condition") ****** * do_filter() * * complete the filter entry ****** FUNCTION do_filter PRIVATE done, k_sample IF EMPTY(M->k_trim) * a confirmed empty expression means eliminate the current filter done = .T. IF .NOT. EMPTY(&k_filter) * cancel any filter that may be active SET FILTER TO * set global filter expression to nul &k_filter = "" ENDIF ELSE IF TYPE(M->k_trim) = "L" * expression evaluates ok done = .T. IF .NOT. (&k_filter == M->k_trim) * change in filter expression..set global variables need_filtr = .T. &k_filter = M->k_trim ENDIF ELSE done = .F. error_msg("Filter must be a Logical expression") ENDIF ENDIF RETURN M->done ****** * clear_dbf() * * clear specified work area..shift higher work areas if requested * * shift values: * 0 = no shift * 1 = shift right (insert) * 2 = shift left (delete) ****** FUNCTION clear_dbf PARAMETERS work_area, shift PRIVATE s_alias,c_area,temp,xtemp,i,file_name,alias_6,n_active * determine number of active work areas n_active = afull(M->dbf) * extract alias of specified work area s_alias = name(dbf[M->work_area]) * area 6 could be affected if shifting due to insert alias_6 = "" * access the list of index files for the current area temp = "ntx" + SUBSTR("123456", M->work_area, 1) DO CASE CASE M->shift = 0 * no shift..no problem dbf[M->work_area] = "" * reduce number of open files by no. of index files + 1 n_files = M->n_files - afull(&temp) - 1 CASE M->shift = 1 * shift right..current data file (if any) will remain open IF .NOT. EMPTY(dbf[6]) * remember the alias alias_6 = name(dbf[6]) * reduce number of open files by no. of index files + 1 n_files = M->n_files - afull(M->ntx6) - 1 ENDIF * shift may not be needed after all shift = IF(EMPTY(dbf[M->work_area]) .OR. M->work_area = 6, 0, 1) * open an empty element in global array of data files array_ins(M->dbf, M->work_area) CASE M->shift = 2 * shift left..current data file will be closed array_del(M->dbf, M->work_area) * shift may not be needed after all shift = IF(EMPTY(dbf[M->work_area]), 0, 2) * reduce number of open files by no. of index files + 1 n_files = M->n_files - afull(&temp) - 1 ENDCASE i = 1 DO WHILE M->i <= M->n_active * select area i c_area = CHR(M->i + ASC("A") - 1) SELECT (M->i) IF M->i = M->work_area .OR. (M->i > M->work_area .AND. M->shift <> 0) * close all work areas to be shifted or closed USE ENDIF * search filters in all active areas for disappearing aliases temp = "kf" + SUBSTR("123456", M->i, 1) IF (((M->s_alias + "->" $ UPPER(&temp)) .OR.; (M->i = M->work_area .AND. .NOT. EMPTY(&temp))); .AND. M->shift <> 1) .OR. (.NOT. EMPTY(M->alias_6) .AND.; M->alias_6 + "->" $ UPPER(&temp) .AND. M->shift = 1) * data file was part of filter expression or none can exist * turn of the filter SET FILTER TO * will need to reset need_filtr = .T. * set global filter expression to nul &temp = "" ENDIF * next i = M->i + 1 ENDDO DO CASE CASE M->shift = 0 * clear array of index files temp = "ntx" + SUBSTR("123456", M->work_area, 1) afill(&temp, "") * clear field list temp = "field_n" + SUBSTR("123456", M->work_area, 1) afill(&temp, "") * clear filter temp = "kf" + SUBSTR("123456", M->work_area, 1) &temp = "" CASE M->shift = 1 * shift right need_filtr = .T. && will need to reset need_ntx = .T. && ditto * count backwards..dbf array may not be contiguous i = 6 DO WHILE EMPTY(dbf[M->i]) * find highest active area i = M->i - 1 ENDDO DO WHILE M->i > M->work_area * shift all higher work areas..list of index files temp = "ntx" + SUBSTR("123456", M->i, 1) xtemp = "ntx" + SUBSTR("123456", M->i - 1, 1) acopy(&xtemp,&temp) * active fields list temp = "field_n" + SUBSTR("123456", M->i, 1) xtemp = "field_n" + SUBSTR("123456", M->i - 1, 1) acopy(&xtemp,&temp) * current rows temp = "cr" + SUBSTR("123456", M->i, 1) xtemp = "cr" + SUBSTR("123456", M->i - 1, 1) acopy(&xtemp,&temp) * current elements temp = "el" + SUBSTR("123456", M->i, 1) xtemp = "el" + SUBSTR("123456", M->i - 1, 1) acopy(&xtemp,&temp) * filter expressions temp = "kf" + SUBSTR("123456", M->i, 1) xtemp = "kf" + SUBSTR("123456", M->i - 1, 1) &temp = &xtemp * next i = M->i - 1 ENDDO * clear the specified work area (i = work_area) xtemp = SUBSTR("123456", M->i, 1) && str(i) for convenience * clear index files list temp = "ntx" + xtemp afill(&temp, "") * clear active fields list temp = "field_n" + xtemp afill(&temp, "") * clear filter expression temp = "kf" + xtemp &temp = "" * reset current rows temp = "cr" + xtemp &temp[2] = row_a[2] &temp[3] = row_a[3] * reset current elements temp = "el" + xtemp afill(&temp, 1) CASE M->shift = 2 * shift left need_filtr = .T. && will need to reset need_ntx = .T. && ditto i = M->work_area DO WHILE M->i < 6 .AND. .NOT. EMPTY(dbf[M->i]) * shift all higher work areas..list of index files temp = "ntx" + SUBSTR("123456", M->i, 1) xtemp = "ntx" + SUBSTR("123456", M->i + 1, 1) acopy(&xtemp,&temp) * active fields list temp = "field_n" + SUBSTR("123456", M->i, 1) xtemp = "field_n" + SUBSTR("123456", M->i + 1, 1) acopy(&xtemp,&temp) * current rows temp = "cr" + SUBSTR("123456", M->i, 1) xtemp = "cr" + SUBSTR("123456", M->i + 1, 1) acopy(&xtemp,&temp) * current elements temp = "el" + SUBSTR("123456", M->i, 1) xtemp = "el" + SUBSTR("123456", M->i + 1, 1) acopy(&xtemp,&temp) * filter expressions temp = "kf" + SUBSTR("123456", M->i, 1) xtemp = "kf" + SUBSTR("123456", M->i + 1, 1) &temp = &xtemp * next i = M->i + 1 ENDDO * clear the last (previously active) work area xtemp = SUBSTR("123456", M->i, 1) && str(i) for convenience * clear index files list temp = "ntx" + M->xtemp afill(&temp, "") * clear active fields list temp = "field_n" + M->xtemp afill(&temp, "") * clear filter expression temp = "kf" + M->xtemp &temp = "" * reset current rows temp = "cr" + M->xtemp &temp[2] = row_a[2] &temp[3] = row_a[3] * reset current elements temp = "el" + M->xtemp afill(&temp, 1) ENDCASE * will need to reset need_field = .T. ** * note: the source and target of relations are identified * by the letter of the work area + the alias ** * get letter of cleared work area c_area = CHR(M->work_area + ASC("A") - 1) i = 1 DO WHILE M->i <= LEN(M->k_relate) * search all active relations IF EMPTY(k_relate[M->i]) * no more active relations EXIT ENDIF IF ((SUBSTR(s_relate[M->i], 1, 1) = M->c_area .OR.; SUBSTR(t_relate[M->i], 1, 1) = M->c_area) .AND. M->shift <> 1) .OR.; (M->shift = 1 .AND. SUBSTR(t_relate[M->i], 1, 1) = "F") * relation must be removed from list array_del(M->s_relate, M->i) array_del(M->k_relate, M->i) array_del(M->t_relate, M->i) need_relat = .T. ELSE IF (M->shift = 2 .AND. SUBSTR(s_relate[M->i], 1, 1) > M->c_area) .OR.; (M->shift = 1 .AND. SUBSTR(s_relate[M->i], 1, 1) >= M->c_area) * source work area was shifted..adjust source area s_relate[M->i] = CHR(ASC(SUBSTR(s_relate[M->i], 1, 1)) +; IF(M->shift = 1, 1, -1)) +; SUBSTR(s_relate[M->i], 2) need_relat = .T. ENDIF IF (M->shift = 2 .AND. SUBSTR(t_relate[M->i], 1, 1) > M->c_area) .OR.; (M->shift = 1 .AND. SUBSTR(t_relate[M->i], 1, 1) >= M->c_area) * target work area was shifted..adjust target area t_relate[M->i] = CHR(ASC(SUBSTR(t_relate[M->i], 1, 1)) +; IF(M->shift = 1, 1, -1)) +; SUBSTR(t_relate[M->i], 2) need_relat = .T. ENDIF * next i = M->i + 1 ENDIF ENDDO IF M->shift <> 0 * re-open active data files in new work areas i = 6 DO WHILE M->i >= M->work_area * search all shifted work areas IF .NOT. EMPTY(dbf[M->i]) * open data file c_area = CHR(M->i + ASC("A") - 1) SELECT (M->i) file_name = dbf[M->i] USE &file_name ENDIF * next i = M->i - 1 ENDDO ENDIF RETURN 0 ****** * save_view() * * save the current view in a ".VEW" file * * note: - the view file is a data base file with a default extension * of ".VEW" and 2 fields: "item_name" and "contents". * - the first 2 items are reserved for the global variables * "cur_dir", and "n_files"..then a variable number of * filter expressions..the remaining items are arrays. * - if the contents of an item will not fit in the contents * field, it will be continued in the next record where * the item_name will be left blank. * - for arrays, only the identifier is saved..the number of * items is the number of elements to fill ****** FUNCTION save_view PRIVATE filename, old_help * save old and set new help codes old_help = M->help_code help_code = 21 * get user entered file name..will default to primary + ".VEW" IF EMPTY(M->view_file) .AND. .NOT. EMPTY(dbf[1]) * default to name of primary data file filename = name(dbf[1]) + ".VEW" ELSE * whatever the last view was filename = M->view_file ENDIF * it's better in a box filebox(".VEW", "vew_list", "vcrea_titl", "do_creavew", .T., 8) * restore help code help_code = M->old_help RETURN 0 ****** * vcrea_titl() * * display title for save view ****** FUNCTION vcrea_titl PARAMETERS sysparam RETURN box_title(M->sysparam, "Save view as...") ****** * do_creavew() * * save the current view in a .VEW file ****** FUNCTION do_creavew PRIVATE i, j, k, m_name, l_name, add_name IF EMPTY(M->filename) error_msg("View file not selected") RETURN .F. ENDIF * select system reserved work area SELECT 10 stat_msg("Generating View File") * add new .VEW files to vew_list if created in current directory only add_name = .NOT. FILE(name(filename) + ".VEW") * create structure extended template CREATE ddbbuuuu.ext * define 2 fields APPEND BLANK REPLACE field_name WITH "ITEM_NAME",field_type WITH "C",field_len WITH 10 APPEND BLANK REPLACE field_name WITH "CONTENTS",field_type WITH "C",field_len WITH 10 * create the view file USE CREATE &filename FROM ddbbuuuu.ext * set global variable view_file = M->filename * open view file..avoid alias conflict USE &view_file ALIAS ddbbuuuu * erase template ERASE ddbbuuuu.ext * 2 global variables always saved APPEND BLANK REPLACE item_name WITH "cur_dir" put_line(cur_dir) APPEND BLANK REPLACE item_name WITH "n_files" put_line(LTRIM(STR(n_files))) i = 1 DO WHILE i <= 6 * filters IF EMPTY(dbf[i]) * no more data files EXIT ENDIF * get variable name for macro expansion m_name = "kf" + SUBSTR("123456", i, 1) IF .NOT. EMPTY(&m_name) * only save active filters APPEND BLANK REPLACE item_name WITH m_name put_line(&m_name) ENDIF * next i = i + 1 ENDDO * save arrays..avoid saving empty elements i = 1 DO WHILE i <= 6 * data file filespecs IF EMPTY(dbf[i]) * no more data files EXIT ENDIF * save one filespec APPEND BLANK REPLACE item_name WITH "dbf" put_line(dbf[i]) * next i = i + 1 ENDDO * save index lists and fields lists l_name = "ntx" FOR k = 1 TO 2 * first the indexed, then the fields i = 1 DO WHILE i <= 6 * index or field list for each data file IF EMPTY(dbf[i]) * no more data files EXIT ENDIF * get array identifier for macro expansion m_name = l_name + SUBSTR("123456", i, 1) j = 1 DO WHILE j <= LEN(&m_name) * index or field list for one data file IF EMPTY(&m_name[j]) * an early exit saves time and disk space EXIT ENDIF * save one index filespec or one field name APPEND BLANK REPLACE item_name WITH m_name put_line(&m_name[j]) * next element j = j + 1 ENDDO * next work area i = i + 1 ENDDO * switch to field lists l_name = "field_n" NEXT i = 1 DO WHILE i <= 3 * relations in 3 arrays..s_relate, k_relate, and t_relate m_name = SUBSTR("skt", i, 1) + "_relate" j = 1 DO WHILE j <= LEN(&m_name) * one array IF EMPTY(&m_name[j]) * an early exit saves time and disk space EXIT ENDIF * one item APPEND BLANK REPLACE item_name WITH m_name put_line(&m_name[j]) * next element j = j + 1 ENDDO * next array i = i + 1 ENDDO * close view file USE * add file name to array of view files IF AT(".VEW", filename) = LEN(filename) - 3 .AND.; FILE(name(filename) + ".VEW") .AND. add_name * add only new .VEW files in the current directory * determine number of first empty element i = afull(vew_list) + 1 IF i <= LEN(vew_list) * room for one more vew_list[i] = filename * must be alphabetical array_sort(vew_list) ENDIF ENDIF stat_msg("") RETURN .T. ****** * put_line() * * store string in contents field(s) of open view file ****** FUNCTION put_line PARAMETERS line PRIVATE pos * assign contents to the current record REPLACE contents WITH line * position to begin fragmentation pos = LEN(contents) + 1 DO WHILE pos <= LEN(line) * continue contents in next record APPEND BLANK REPLACE contents WITH SUBSTR(line, pos) * next chunk pos = pos + LEN(contents) ENDDO RETURN 0 ****** * set_from() * * restore View from .VEW file ****** FUNCTION set_from PARAMETERS from_view PRIVATE filename, old_help * save old and set new help codes old_help = M->help_code help_code = 21 * default to previous View file if any filename = M->view_file IF M->from_view * called from set_view IF filebox(".VEW", "vew_list", "vopen_titl", "do_openvew", .F., 8) <> 0 * indicate new View has been set keystroke = 13 ENDIF ELSE * just do it do_openvew() ENDIF * restore help code help_code = M->old_help RETURN 0 ****** * vopen_titl() * * display title for restore view ****** FUNCTION vopen_titl PARAMETERS sysparam RETURN box_title(M->sysparam, "Restore view from...") ****** * do_openvew() * * restore view from .VEW file * * note: this function is called when the enter key is * pressed while the cursor is on the Ok button ****** FUNCTION do_openvew PRIVATE m_name, i, done DO CASE CASE EMPTY(M->filename) error_msg("View file not selected") done = .F. CASE .NOT. FILE(M->filename) error_msg("Can't open " + M->filename) done = .F. OTHERWISE * select system reserved work area SELECT 10 * open .VEW file..avoid alias conflict USE &filename ALIAS ddbbuuuu IF .NOT. (TYPE("item_name") = "C" .AND. TYPE("contents") = "C") USE error_msg("Invalid view file") RETURN .F. ENDIF * ok to restore View..set global variable view_file = M->filename * entire View will need setup STORE .T. TO need_field,need_ntx,need_relat,need_filtr stat_msg("Restoring view") * clear the current view if any i = 6 DO WHILE M->i > 0 IF .NOT. EMPTY(dbf[M->i]) * clear one work area clear_dbf(M->i, 0) ENDIF * next i = M->i - 1 ENDDO * select system reserved work area SELECT 10 * "cur_dir" and "n_files" always saved first cur_dir = get_line() n_files = VAL(get_line()) IF TRIM(item_name) == "k_filter" * continued support for old format REPLACE item_name WITH "kf1" kf1 = get_line() ELSE DO WHILE SUBSTR(item_name, 1, 2) == "kf" * get one filter expression m_name = TRIM(item_name) * assign the expression &m_name = get_line() ENDDO ENDIF * all remaining information to be stored in global arrays DO WHILE .NOT. EOF() * get next array identifier and initialize subscript m_name = TRIM(item_name) i = 1 * fill one array DO WHILE TRIM(item_name) == m_name * fill one element of array &m_name[i] = get_line() * next element i = i + 1 ENDDO ENDDO * close the view file USE * open all data files in their select areas i = 1 DO WHILE M->i <= 6 IF EMPTY(dbf[M->i]) * no more data files to open EXIT ENDIF * select the corresponding work area SELECT (M->i) * open the data file filename = dbf[M->i] USE &filename * next work area i = M->i + 1 ENDDO stat_msg("") done = .T. ENDCASE RETURN M->done ****** * get_line() * * assemble contents of variable from .VEW file ****** FUNCTION get_line PRIVATE line * assign contents from first record line = TRIM(contents) SKIP DO WHILE LEN(TRIM(item_name)) = 0 .AND. .NOT. EOF() * blank name field means contents are continued in next record line = line + TRIM(contents) SKIP ENDDO RETURN line * EOF DBUVIEW.PRG