Piper's Pit BBS/FTP: ibm 0010

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

/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / HORWITH.ZIP / PRC.PRG

Wrap

Text File | 1990-05-24 | 19.6 KB | 668 lines

* PRC.PRG Test Application Procedures ****************************************************** * Below this line belongs in library ****************************************************** * ─────────────────────────────────────────────────────────── FUNC opendata PARA malias PRIV i,mindex,mkey PRIV index1,index2,index3,index4,index5,index6,; index7,index8,index9,index10,index11,index12 STORE [] TO index1,index2,index3,index4,index5,index6,; index7,index8,index9,index10,index11,index12 IF SELE([datahead])=0 DO datahead ELSE SELE datahead ENDIF SEEK UPPER(malias) morder = [] FOR i = 1 TO p_maxindex mntx = [index]+LTRIM(STR(i)) IF ! EMPTY(&mntx.) mkey = [indexkey]+LTRIM(STR(i)) MAKE_NTX(M->malias,&mntx.,&mkey.) M->&mntx = &mntx ENDIF NEXT IF SELE(M->malias) = 0 SELE 0 USE &malias ELSE SELE &malias ENDIF SET INDE TO &index1,&index2,&index3,&index4,&index5,&index6,; &index7,&index8,&index9,&index10,&index11,&index12 mret = ! NETERR() RETU mret * ─────────────────────────────────────────────────────────── PROC dataflds && call dataflds database CHECK_NTX([dataflds],[dataflds],[alias+field_name]) CHECK_OPEN([dataflds],[dataflds]) RETURN * ─────────────────────────────────────────────────────────── PROC datahead && call datahead database CHECK_NTX([datahead],[datahead],[alias]) CHECK_OPEN([datahead],[datahead]) RETURN * ─────────────────────────────────────────────────────────── PROC datarela && call dataflds database CHECK_NTX([datarela],[datarela],[s_alias+s_field]) CHECK_OPEN([datarela],[datarela]) RETURN * ─────────────────────────────────────────────────────────── FUNC check_open PRIVATE ntx1,ntx2,ntx3,ntx4,ntx5,ntx6,ntx7,ntx8,ntx9,ntx10,ntx11,mret STORE [] TO ntx1,ntx2,ntx3,ntx4,ntx5,ntx6,ntx7,ntx8,ntx9,ntx10,ntx11 PARA dbf,ntx1,ntx2,ntx3,ntx4,ntx5,ntx6,ntx7,ntx8,ntx9,ntx10,ntx11 IF ! OPEN_FILE(dbf,ntx1,ntx2,ntx3,ntx4,ntx5,ntx6,ntx7,ntx8,ntx9,ntx10,ntx11) DO kbhit WITH [Error opening ] + dbf +[. Returning to menu. Any key ...] BREAK ENDIF RETU [] * ─────────────────────────────────────────────────────────── FUNC check_ntx PARA dbf,ntx,key IF ! MAKE_NTX(M->dbf,M->ntx,M->key) DO kbhit WITH [Error opening ] + dbf +[ for indexing. Returning to menu. Any key ...] BREAK ENDIF RETU [] * ─────────────────────────────────────────────────────────── FUNC dispfile && use memofield to show code PARA fname BEGIN SEQUENCE IF ! ([PRG] $ UPPER(ALLTRIM(fname)) .OR. [TXT] $ UPPER(ALLTRIM(fname))) DO kbhit WITH [Can only show PRGs and TXTs. Sorry. Anykey continues ...] BREAK ENDIF PRIV calls,mfname,mpname,msname,mscreen mfname = ALLTRIM(fname) mpname = SUBS(mfname,1,AT([.],mfname)-1) msname = SUBS(mfname,AT([.],mfname)+1) calls = 0 CO_PUSH() && fdi89 - co_procs CO_CHG(c_pop3) && fdi89 - co_procs mscreen = SAVESCR(0,0,24,79) @ 24,0 @ 24,0 SAY 'Press [Esc] when done.' FRAMEBOX(0,0,23,79,[File: ]+mfname) CO_CHG(c_backdrop) && fdi89 - co_procs MEMOEDIT(MEMOREAD([&mpname..&msname]),1,1,22,78,.F.,[memofunc],165) CO_POP() && fdi89 - co_procs RESTSCR(mscreen) END SEQUENCE RETU [] PROC std_e && Standard Edit - INCORPORATES DATABASE DICTIONARY mloop = .T. fromread = .T. IF DELE() DO kbhit WITH [Record has been deleted. Any key continues...] RETU ENDIF * ─── Lock record ──────────────────────── DO WHIL ! rec_lock(5) ?? CHR(7) DO yes_no WITH [Record not available. Do you wish to retry? (Y/N)] IF myn = [N] RETURN && go back to browse ENDIF ENDDO * record is now locked ! CURS_ON() * ─── Initialize mem vars ──────────────── oldkey = &key_field IF full_screen mloop = .F. IF browse CO_PUSH() CO_CHG(c_fullscr,c_frame) DO &module._frame ENDIF DO &meminit WITH [E] CO_CHG(curr_grp,c_sayget) @ 24,0 @ 24,0 SAY scr_prompt DO &module._gets WITH [M] READ IF ! ESC() && not keeping these changes DO &mreplace && replace fields with current mem vars ENDIF IF browse .AND. ! stayinfull CO_POP() RESTSCR(mscreen) ENDIF ELSE DO &meminit WITH [E] && initialize mem vars. ** CO_CHG(curr_grp,c_sayget) DO &module._gets WITH cur_row READ IF ESC() @ cur_row,left_col+4 SAY &wfields ELSE * Check in dictionary for changed keyfields IF ChkRelEdit(ALIAS()) DO &mreplace && replace fields with current mem vars ENDIF IF oldkey = &key_field @ cur_row,left_col+4 SAY &wfields ELSE && Changed a key field, so exit! mloop = .F. ENDIF ENDIF @ 24,0 @ 24,0 SAY mprompt ENDIF UNLOCK CURS_OFF() RETURN FUNC DELETING RETU [D] $ [mchoice+fchoice] FUNC std_d && - INCORPORATES DATABASE DICTIONARY PRIVATE deleted deleted = .F. BEGIN SEQUENCE IF ! yes_no( [Sure you want to delete this one? (Y/N) ] ) DO kbhit WITH [Spared! Any key continues...] BREAK ENDIF IF ! ChkRelDele(ALIAS()) BREAK ENDIF DO WHIL ! rec_lock(5) ?? CHR(7) IF ! yes_no( [Record not available. Do you wish to retry? (Y/N)] ) BREAK && go back to browse ENDIF ENDDO * record is now locked! DELETE deleted = .T. UNLOCK SKIP && get to record after deletion. IF OFF() none_left = .T. BOTT() ELSE none_left = .F. ENDIF lastrec = RECNO() && new last record, we deleted old one browse = DEFAULT([browse],.F.) IF browse * shift the screen UP, from cur_row: IF cur_row <> lastrow SCROLL(cur_row,left_col+1,lastrow,right_col-1,1) && up one ENDIF * display the new bottom record (one past old bottom) SKIP (lastrow - cur_row) IF OFF() .OR. none_left SCROLL(lastrow,left_col+1,lastrow,right_col-1,0) IF cur_row = lastrow && were we on the last? cur_row = MAX(firstrow, cur_row - 1) && up one ENDIF lastrow = MAX(firstrow,lastrow - 1) && up one BOTT() ENDIF IF ! OFF() @ lastrow,left_col+4 SAY &wfields && new bottom record ENDIF GOTO lastrec white = .F. ENDIF END SEQUENCE RETURN M->deleted FUNC cascade PARA mode,; && edit or delete continue && return .T. as soon as related data is found continue = IF(TYPE([continue])=[U],.T.,.F.) PRIV ctrlfield,s_a,s_f,mret mret = .F. BEGIN SEQUENCE WAIT_ON([Checking related files ...]) ctrlfld = s_alias+s_field s_a = ALLTRIM(s_alias) s_f = ALLTRIM(s_field) mpreedit = &s_a.->&s_f. DO WHILE ctrlfld = s_alias+s_field t_alias = t_alias t_field = t_field * Decide if there is an index to use IF SELE(t_alias)=0 OPENDATA(t_alias) ENDIF SELE &t_alias t_order = INDEXORD() indexed = .F. j = 1 DO WHILE ! EMPTY(INDEXKEY(j)) IF UPPER(INDEXKEY(j)) = UPPER(datarela->t_field) SET ORDER TO j indexed = .T. ENDIF j = j + 1 ENDDO IF indexed SEEK mpreedit IF FOUND() .AND. ! continue mret = .T. BREAK ENDIF t_field = t_field DO WHILE t_field == mpreedit REC_LOCK(5) IF mode = [edit] REPL &t_field WITH M->&mfield. ENDIF IF mode = [delete] DELETE ENDIF UNLOCK SEEK mpreedit ENDDO SET ORDE TO t_order ELSE IF ! continue LOCA FOR &t_field = mpreedit IF FOUND() mret = .T. BREAK ENDIF ENDIF IF mode = [edit] REC_LOCK(5) REPL &t_field WITH M->&mfield. FOR &t_field = mpreedit UNLOCK ENDIF IF mode = [delete] DELE FOR &t_field = mpreedit .AND. REC_LOCK(5) ENDIF ENDIF SELE datarela SKIP ENDDO mret = .T. END SEQUENCE WAIT_OFF() RETU mret FUNC chkreledit PARA source_alias PRIV i,mret,mfield,ctrlfld,t_alias,t_field,indexed,mpreedit,; j,mfunc,num_of_fields,dummy mret = .T. malias = SELE() num_of_fields = &source_alias.->(FCOUNT()) FOR i = 1 TO num_of_fields mfield = &source_alias.->(FIELD(i)) IF &source_alias.->&mfield. <> M->&mfield && has data been changed seekval = SUBS(source_alias+SPAC(8),1,8)+mfield DO datarela SEEK seekval IF FOUND() DO CASE CASE edit_rule = [STOP] IF CASCADE([edit],.T.) KBHIT([Sorry - Related data found - No edit allowed on field: ] + mfield) mret = .F. ENDIF CASE edit_rule = [CASCADE] CASCADE([edit]) CASE [(] $ edit_rule mfunc = edit_rule dummy = &mfunc. ENDCASE ENDIF ENDIF NEXT SELE (malias) RETU mret FUNC chkreldele PARA source_alias PRIV i,mret,mfield,ctrlfld,t_alias,t_field,indexed,mpreedit,j,mfunc,dummy mret = .T. malias = SELE() num_of_fields = &source_alias->(FCOUNT()) FOR i = 1 TO num_of_fields mfield = &source_alias.->(FIELD(i)) seekval = SUBS(source_alias+SPAC(8),1,8)+mfield DO datarela SEEK seekval IF FOUND() DO CASE CASE dele_rule = [STOP] IF CASCADE([delete],.T.) KBHIT([Sorry - Related data found - No delete allowed.]) mret = .F. ENDIF CASE dele_rule = [CASCADE] CASCADE([delete]) CASE [(] $ dele_rule mfunc = delerule dummy = &mfunc. ENDCASE ENDIF NEXT SELE (malias) RETU mret FUNC vchk PARA mret,mess mess = IF(TYPE([M->mess])=[U],[Invalid Entry, Please Re-Enter Data.],M->mess) IF ! mret KBHIT(mess+[ Anykey ...]) ENDIF RETU mret PROC rebuild PRIV askpack,pack_em,i,num_ele,mname,needed,pick_all askpack = .T. PARA askpack DO datahead BEGIN SEQUENCE IF askpack pack_em = yes_no([Also pack the databases?]) ELSE pack_em = .F. ENDIF ESCBREAK() * create an array of database file names: WAIT_ON() num_ele = ADIR([*.dbf]) PRIVATE files[num_ele] ADIR([*.dbf],files) SELE 0 CREATE temp&msta USE temp&msta EXCL MAKE_FIELD([name],[C],8) CREA temp2&msta FROM temp&msta USE temp2&msta EXCL FOR i = 1 TO num_ele IF ! [temp] $ LOWER(files[i]) .AND. ! [datahead] $ LOWER(files[i]) APPE BLAN files[i] = SUBS(files[i],1,AT([.],files[i])-1) REPL name WITH files[i] ENDIF NEXT INDE ON name TO temp&msta GO TOP WAIT_OFF() mtitle = [Databases] wtitle = [────Name─────] wfields= [name] PRIV apicks[num_ele] AFILL([apicks],[]) pick_all = [ ] @ 24,0 @ 24,0 SAY [P)ick certain databases or rebuild A)ll (P/A) ] GET M->pick_all PICT [!] VALID M->pick_all $ [PA] SET CONF OFF READ SET CONF ON @ 24,0 IF pick_all = [P] APICKS(apicks,6,15,20) ELSE FOR i = 1 TO RECCOUNT() apicks[i] = i NEXT ENDIF *-------------now process all the elements of the array: BOX(6,15,11,47,[Erasing old index files],.F.) FOR i = 1 TO LEN(apicks) IF EMPTY(apicks[i]) EXIT ENDIF SELE temp2&msta GOTO apicks[i] dbf_name = name IF ! EMPTY(dbf_name) SELE 0 failed = .T. DO WHILE failed USE &dbf_name EXCLUSIVE failed = NETERR() IF failed IF YES_NO(dbf_name+[ is in use elsewhere. Try again? ]) LOOP ELSE KBHIT([Exiting rebuild routine ...],5) BREAK ENDIF ENDIF ENDDO IF M->pack_em SAY_MESS(dbf_name,[Packing]) COPY TO temp&msta. && will shrink the memo fields ZAP APPE FROM temp&msta. ENDIF SELE datahead SEEK dbf_name IF FOUND() SAY_MESS(dbf_name,[Rebuilding Indices]) OPENDATA(dbf_name) USE ELSE KBHIT([File ]+ TRIM(dbf_name) + [ is not in data dictionary. Will not reindex. Anykey ...],5) ENDIF ENDIF NEXT i END SEQUENCE ERASE temp&msta.dbf ERASE temp2&msta.dbf ERASE temp&msta.ntx CLOSE DATA RETURN PROC say_mess PARA file,message @ 09,16 SAY SPAC(46) SCROLL(10,16,19,61,1) @ 19,17 SAY DOTS(M->file,20)+M->message @24,0 SAY [] && position the cursor in case there are DOS messages RETURN FUNC libhelp PARA call_prg,input_var PRIV datafound,libfound,malias malias = ALIAS() libfound = .T. datafound = .F. IF ! EMPTY(input_var) DO datarela SEEK SUBS(malias+SPAC(8),1,8)+TRIM(input_var) datafound = FOUND() ENDIF DO CASE CASE datafound IF ! EMPTY(help_mod) PRIV mscreen,targetdbf,defmodule defmodule = help_mod+[_def] targetdbf = t_alias targetfld = t_field SEEKHELP(targetdbf) DO &defmodule mscreen = WINDOW() &input_var = IF(ESC(), M->&input_var, &targetfld) RESTSCR(mscreen) KEYBOARD CHR(13) ENDIF CASE TYPE(M->input_var) = [D] && date variable DO cal_help WITH M->input_var CASE call_prg = [GET_KEY] DO hc_help WITH [browsehelp] CASE call_prg = [MEMOEDIT] DO hc_help WITH [memokeys] SET CURSOR ON CASE input_var = [PRINTER] .OR. call_prg = [PRINTIT] IF FILE([stdprint.dbf]) DO pick_print ELSE DO netprint ENDIF OTHERWISE libfound = .F. ENDCASE RETU M->libfound FUNC savescr && Originally by Greg Martin, Modified by Financial Dynamics PARA tr,lc,br,rc PRIV screen,corners,mret,mtemp screen = SAVESCREEN(tr,lc,br,rc) corners = CHR(tr)+CHR(lc)+CHR(br)+CHR(rc) IF TYPE([scrfile])=[U] .OR. LEN(corners + M->screen) < 512 mret = corners + M->screen ELSE mret = NEXTSCRFILE() screen = corners+screen SCRNWRIT(mret, M->screen) ENDIF RETU mret FUNC restscr && Originally by Greg Martin, Modified by Financial Dynamics PARA screen PRIV tr,lc,br,rc IF ASC(SUBS(M->screen,1,1)) > 24 screen = SCRNREAD(M->screen) ENDIF tr = ASC(SUBS(screen,1,1)) lc = ASC(SUBS(screen,2,1)) br = ASC(SUBS(screen,3,1)) rc = ASC(SUBS(screen,4,1)) RESTSCREEN(M->tr,M->lc,M->br,M->rc,SUBS(M->screen,5)) RETU .T. FUNC nextscrfile * scrfile is public counter - static in 5.0 * scrfile will be 6 bytes scrfile = RIGHT([000000]+ALLTRIM(STR(VAL(scrfile)+1,4,0)),6) RETU scrfile * tempscr.txt structure * Byte 1 - 5120: headers * Header: 1-6 screen number * 7-12 starting byte for screen * 13-16 number of bytes * 5121 to end: screens FUNC scrnwrit PARA scrname,screen PRIV handle,mhead,len,start,headpos IF ! FILE([tempsc&msta..scr]) handle = FCREATE([tempsc&msta..scr]) FWRITE(handle,SPAC(5120)) && seed len of header area ELSE handle = FOPEN([tempsc&msta..scr],2) ENDIF len = RIGHT([0000]+LTRIM(STR(LEN(screen),4,0)),4) start = RIGHT([000000]+LTRIM(STR(FSEEK(handle,0,2))),6) mhead = scrname + ; && name of screen, 6 bytes start + ; && start of screen, 6 bytes len && length of screen, 4 bytes headpos = (VAL(scrname)*16)-15 FSEEK(handle,headpos,0) && move to end of file FWRITE(handle,mhead) FSEEK(handle,0,2) FWRITE(handle,screen) FCLOSE(handle) RETU [] FUNC scrnread PARA scrname PRIV handle,len,headpos,buffer,start,len,mret handle = FOPEN([tempsc&msta..scr],0) headpos = (VAL(scrname)*16)-15 FSEEK(handle,headpos,0) buffer = FREADSTR(handle,16) IF VAL(scrname) = VAL(SUBS(buffer,1,6)) start = VAL(SUBS(buffer,7,6)) len = VAL(SUBS(buffer,13,4)) FSEEK(handle,start,0) mret = SPAC(len) FREAD(handle,@mret,len) ELSE KBHIT([Error in restore screen. Breaking to Menu ...]) BREAK ENDIF FCLOSE(handle) RETU mret PROC leave PARAMETER r1,c1 PRIVATE manswer CO_PUSH() CO_CHG(c_pop3) manswer = [ ] r1 = DEFAULT([r1],10) c1 = DEFAULT([c1],23) DO BOX WITH r1,c1,4,44,[Leave the system], .F. CO_CHG(curr_grp, c_sayget) @ r1+3,c1+3 SAY [Sure you want to quit? ] GET manswer PICT [!] SET CONFIRM OFF READ SET CONFIRM ON IF manswer $ [QY] ERASE tempsc&msta..scr SET COLO TO W/N && white on black CLEAR QUIT ENDIF CO_POP() RETU FUNC maxindex PRIV mret,mfield DO datahead FOR i = FCOUNT() TO 1 STEP -1 mfield = FIELD(i) IF LEN(ALLTRIM(mfield))<=7 .AND. UPPER(SUBS(mfield,1,5)) = [INDEX] mret = VAL(SUBS(mfield,AT([X],mfield)+1)) EXIT ENDIF NEXT USE RETU mret FUNC dd BOXX(10,10,[Loading Data Dictionary ...]) OVERLAY([g:dd],0) RETU []